Browse Source

Use styler to style code

testing-framework
Noam Ross Noam Ross 1 year ago
parent
commit
984b8719e5
17 changed files with 300 additions and 224 deletions
  1. +2
    -2
      R/addins.R
  2. +57
    -37
      R/dedoc.R
  3. +29
    -25
      R/diff.R
  4. +2
    -3
      R/docx-utils.R
  5. +12
    -8
      R/extract-outputs.R
  6. +15
    -15
      R/get_style_dist.R
  7. +16
    -9
      R/officer-embed.R
  8. +1
    -1
      R/officer-modify_style.R
  9. +2
    -1
      R/pandocoml.R
  10. +2
    -4
      R/preprocessor.R
  11. +39
    -32
      R/redoc.R
  12. +8
    -9
      R/stri-utils.R
  13. +34
    -21
      R/utils.R
  14. +72
    -49
      R/wrap.R
  15. +0
    -1
      man/make_preknitter.Rd
  16. +7
    -5
      tests/spelling.R
  17. +2
    -2
      tests/testthat/test-roundtrip.R

+ 2
- 2
R/addins.R View File

@@ -34,8 +34,8 @@ roundtrip_active_file <- function() {
clean = TRUE
)
rfile <- redoc_extract_rmd(docfile,
type = "roundtrip", dir = tempdir(),
overwrite = TRUE
type = "roundtrip", dir = tempdir(),
overwrite = TRUE
)
rstudioapi::setDocumentContents(readfile(rfile), active_file$id)
rstudioapi::setCursorPosition(cursor_position, active_file$id)


+ 57
- 37
R/dedoc.R View File

@@ -5,7 +5,7 @@
#'
#' @details R chunks may be lost in the editing process if using non-Microsoft
#' word processors (e.g. LibreOffice or in copy-and-pasting text into a new document.
#'
#'
#' @param docx The `.docx`` file to convert
#' @param to the filename to write the resulting `.Rmd` file. The default is to
#' use the same basename as the docx document
@@ -45,7 +45,7 @@ dedoc <- function(docx, to = NULL, dir = ".",
inline_missing = "omit",
wrap = 80, overwrite = FALSE,
orig_docx = NULL, orig_codefile = NULL,
verbose = FALSE ) {
verbose = FALSE) {
if (!is_redoc(docx) && is.null(orig_codefile) && is.null(orig_docx)) {
md_only <- TRUE
if (verbose) {
@@ -77,10 +77,14 @@ Returning markdown only. Alternate data may be provided via `orig_codefile or `o
if (!md_only) {
codelist <- sort_by(codelist, "lineno")
md <- merge_yaml_headers(md, codelist)
md <- restore_code(md, codelist = list_subset(codelist, type = "block"),
missing = block_missing)
md <- restore_code(md, codelist = list_subset(codelist, type = "inline"),
missing = inline_missing)
md <- restore_code(md,
codelist = list_subset(codelist, type = "block"),
missing = block_missing
)
md <- restore_code(md,
codelist = list_subset(codelist, type = "inline"),
missing = inline_missing
)
md <- remove_extra_newlines(md)
}

@@ -119,13 +123,16 @@ redoc_extract_rmd <- function(docx, type = c("original", "roundtrip"),
assert_redoc(docx)
type <- match.arg(type)
rmdfiles <- list.files(file.path(docx$package_dir, "redoc"),
pattern = "\\.(r|R)md$",
full.names = TRUE)
if (type == "original")
pattern = "\\.(r|R)md$",
full.names = TRUE
)
if (type == "original") {
rmdfile <- stri_subset_regex(rmdfiles, "(?:\\.preprocessed\\.|\\.roundtrip\\.)",
negate = TRUE)[1]
else if (type == "roundtrip")
negate = TRUE
)[1]
} else if (type == "roundtrip") {
rmdfile <- stri_subset_fixed(rmdfiles, ".roundtrip.")
}


if (is.null(to)) to <- basename(rmdfile)
@@ -139,8 +146,9 @@ redoc_extract_code <- function(docx) {
docx <- to_docx(docx)
assert_redoc(docx)
codefile <- list.files(file.path(docx$package_dir, "redoc"),
pattern = "\\.codelist\\.yml$",
full.names = TRUE)
pattern = "\\.codelist\\.yml$",
full.names = TRUE
)
codelist <- read_yaml(codefile)
codelist
}
@@ -158,25 +166,33 @@ restore_code <- function(md, codelist, missing) {
if (!is.na(marker_line)) {
last_detected_end <- marker_line + stri_count_lines(item$code)
md <- stri_replace_first_fixed(md, marker, item$code,
vectorize_all = FALSE)
vectorize_all = FALSE
)
md <- stri_replace_all_fixed(md, marker, "")
} else if (missing != "omit") {
if (missing == "comment") {
if (item$type == "inline") {
restorecode <- stri_join("<!--", item$code, ", originally line ",
item$lineno, " -->\n")
restorecode <- stri_join(
"<!--", item$code, ", originally line ",
item$lineno, " -->\n"
)
} else {
restorecode <- stri_join("<!-- originally line ", item$lineno, "\n",
item$code, "\n -->\n")
restorecode <- stri_join(
"<!-- originally line ", item$lineno, "\n",
item$code, "\n -->\n"
)
}
} else {
restorecode <- stri_join(item$code, "\n")
}
restoreline <- get_prior_empty_line_loc(md,
max(last_detected_end, item$lineno + offset)
restoreline <- get_prior_empty_line_loc(
md,
max(last_detected_end, item$lineno + offset)
)
md <- insert_at_prior_empty_line(
md, restorecode,
item$lineno + offset
)
md <- insert_at_prior_empty_line(md, restorecode,
item$lineno + offset)
offset <- offset + 2
}
}
@@ -190,8 +206,8 @@ merge_yaml_headers <- function(md, codelist) {
old_header <- list_subset(codelist, label = "yamlheader")[[1]]
new_yaml <- stri_extract_first_regex(md, "(?s)\\A\\s*---\\n.*?\\n---\\n")
if (is.null(old_header) ||
all(is.na(old_header)) || length(old_header) == 0) {
attr(md, "yaml_offset") <- stri_count_fixed(new_yaml, '\n') - 1
all(is.na(old_header)) || length(old_header) == 0) {
attr(md, "yaml_offset") <- stri_count_fixed(new_yaml, "\n") - 1
return(md)
}

@@ -203,12 +219,16 @@ merge_yaml_headers <- function(md, codelist) {
old_metadata[[name]] <- new_metadata[[name]]
}
}
merged_yaml <- oneline("---",
stri_replace_last_fixed(
as.yaml(old_metadata,
handlers = NULL),
"\n", ""),
"---")
merged_yaml <- oneline(
"---",
stri_replace_last_fixed(
as.yaml(old_metadata,
handlers = NULL
),
"\n", ""
),
"---"
)
yaml_offset <- stri_count_lines(merged_yaml) -
stri_count_lines(old_header$code)

@@ -286,20 +306,20 @@ convert_docx_to_md <- function(docx,
"--lua-filter=",
system.file("lua-filters", "revchunks.lua", package = "redoc")
))
from_format = "docx+styles+empty_paragraphs"
from_format <- "docx+styles+empty_paragraphs"
} else {
filter_opts <- character(0)
from_format = "docx"
from_format <- "docx"
}
other_opts <- c("--standalone") # note adding metadata args for additional title block elements here might work (possibly as title block variable), though can't control order?
opts <- c(filter_opts, track_opts, wrap_opts, other_opts)
md_tmp <- tempfile(fileext = ".md")
pandoc_convert(docx,
from = from_format,
to = "markdown",
output = md_tmp,
options = opts,
verbose = verbose
from = from_format,
to = "markdown",
output = md_tmp,
options = opts,
verbose = verbose
)
return(readfile(md_tmp))
}

+ 29
- 25
R/diff.R View File

@@ -28,13 +28,12 @@ redoc_diff <- function(docx,
target = "original",
current = "current",
track_changes = "comments_only",
block_missing = "comment",
block_missing = "comment",
inline_missing = "omit",
wrap = 80,
mode = "sidebyside", context = "auto",
tar.banner = NULL, cur.banner = NULL,
...) {

stopifnot(target %in% c("original", "roundtrip", "current"))
stopifnot(current %in% c("original", "roundtrip", "current"))

@@ -43,40 +42,45 @@ redoc_diff <- function(docx,
tmpd <- tempdir()
comps <- lapply(c(target, current), function(x) {
switch(x,
original = redoc_extract_rmd(docx,
type = "original", dir = tmpd,
overwrite = TRUE
),
roundtrip = redoc_extract_rmd(docx,
type = "roundtrip", dir = tmpd,
overwrite = TRUE
),
current = dedoc(docx, to = "current.Rmd", dir = tmpd,
track_changes = track_changes,
inline_missing = inline_missing,
wrap = wrap, overwrite = TRUE)
original = redoc_extract_rmd(docx,
type = "original", dir = tmpd,
overwrite = TRUE
),
roundtrip = redoc_extract_rmd(docx,
type = "roundtrip", dir = tmpd,
overwrite = TRUE
),
current = dedoc(docx,
to = "current.Rmd", dir = tmpd,
track_changes = track_changes,
inline_missing = inline_missing,
wrap = wrap, overwrite = TRUE
)
)
})

labs <- lapply(c(target, current), function(x) {
switch(x,
original = "Original R Markdown",
roundtrip = "Original R Markdown (roundtripped)",
current = "Current Word Document"
original = "Original R Markdown",
roundtrip = "Original R Markdown (roundtripped)",
current = "Current Word Document"
)
})

if (is.null(tar.banner)) tar.banner <- labs[[1]]
if (is.null(tar.banner)) tar.banner <- labs[[2]]

diff <- diffFile(target = comps[[1]], comps[[2]],
mode = mode, context = context,
tar.banner = labs[[1]], cur.banner = labs[[2]],
pager = list(file.path = tempfile(fileext = ".html")),
...)
diff <- diffFile(
target = comps[[1]], comps[[2]],
mode = mode, context = context,
tar.banner = labs[[1]], cur.banner = labs[[2]],
pager = list(file.path = tempfile(fileext = ".html")),
...
)

#Temporary workaround for diffobj issue #133
if (isTRUE(all.equal(readLines(comps[[1]]), readLines(comps[[2]]))))
diff <- diff[-c(1:2),]
# Temporary workaround for diffobj issue #133
if (isTRUE(all.equal(readLines(comps[[1]]), readLines(comps[[2]])))) {
diff <- diff[-c(1:2), ]
}
return(diff)
}

+ 2
- 3
R/docx-utils.R View File

@@ -12,7 +12,8 @@
is_redoc <- function(docx) {
docx <- to_docx(docx)
codefile <- list.files(file.path(docx$package_dir, "redoc"),
pattern = "\\codelist\\.yml$")
pattern = "\\codelist\\.yml$"
)
return(as.logical(length(codefile)))
}

@@ -49,7 +50,6 @@ redoc_example_rmd <- function() {
#' @aliases redoc_examples
redoc_example_docx <- function() {
system.file("examples", "example.docx", package = "redoc")

}

#' @export
@@ -57,5 +57,4 @@ redoc_example_docx <- function() {
#' @aliases redoc_examples
redoc_example_edited_docx <- function() {
system.file("examples", "example-edited.docx", package = "redoc")

}

+ 12
- 8
R/extract-outputs.R View File

@@ -6,14 +6,18 @@ extract_outputs <- function(docx,
verbose = FALSE) {
md_tmp <- tempfile(fileext = ".md")
pandoc_convert(normalizePath(docx),
from = "docx+styles+empty_paragraphs",
to = "markdown+fenced_code_blocks",
options = c(paste0("--lua-filter=",
system.file("lua-filters", "extract-outputs.lua", package = "redoc")),
"--standalone"
),
output = md_tmp,
verbose = verbose)
from = "docx+styles+empty_paragraphs",
to = "markdown+fenced_code_blocks",
options = c(
paste0(
"--lua-filter=",
system.file("lua-filters", "extract-outputs.lua", package = "redoc")
),
"--standalone"
),
output = md_tmp,
verbose = verbose
)
yml <- yaml::read_yaml(md_tmp)
yml
}

+ 15
- 15
R/get_style_dist.R View File

@@ -5,20 +5,21 @@ get_style_distribution <- function(docx) {
sxml <- read_xml(unz(docx, filename = "word/styles.xml"))
txml <- read_xml(unz(docx, filename = "word/theme/theme1.xml"))
st <- xml_find_all(sxml, "/w:styles/w:style")
all_desc <- data.frame(stringsAsFactors = FALSE,
style_type = xml_attr(st, "type"),
style_id = xml_attr(st, "styleId"),
style_name = xml_attr(xml_child(st, "w:name"), "val"),
based_on = xml_attr(xml_child(st, "w:basedOn"), "val"),
next_style = xml_attr(xml_child(st, "w:next"), "val"),
p_space_before = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "before"),
p_space_after = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "after"),
p_space_line = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "line"),
p_space_linerule = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "lineRule"),
p_ind_left = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "left"),
p_ind_right = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "right"),
p_ind_hanging = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "hanging"),
p_ind_firstLine = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "firstLine")
all_desc <- data.frame(
stringsAsFactors = FALSE,
style_type = xml_attr(st, "type"),
style_id = xml_attr(st, "styleId"),
style_name = xml_attr(xml_child(st, "w:name"), "val"),
based_on = xml_attr(xml_child(st, "w:basedOn"), "val"),
next_style = xml_attr(xml_child(st, "w:next"), "val"),
p_space_before = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "before"),
p_space_after = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "after"),
p_space_line = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "line"),
p_space_linerule = xml_attr(xml_find_first(st, "w:pPr/w:spacing"), "lineRule"),
p_ind_left = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "left"),
p_ind_right = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "right"),
p_ind_hanging = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "hanging"),
p_ind_firstLine = xml_attr(xml_find_first(st, "w:pPr/w:ind"), "firstLine")
)
}

@@ -28,4 +29,3 @@ get_style_property <- function(docx, style_id, sub = c("", "pPr", "rPr"), el, at
sxml <- read_xml(unz(docx, filename = "word/styles.xml"))
st <- xml_find_all(sxml, stri_c("/w:styles/w:style[@w:styleId=\"", style_id, "\"]"))
}


+ 16
- 9
R/officer-embed.R View File

@@ -5,10 +5,13 @@ embed_files <- function(docx, files, internal_dir = NULL) {
if (!file.exists(file)) next
if (file.info(file)$isdir) {
embed_files(docx, list.files(file, full.names = TRUE),
internal_dir = do.call(file.path,
as.list(c(internal_dir, basename(file)))))
internal_dir = do.call(
file.path,
as.list(c(internal_dir, basename(file)))
)
)
} else {
embed_file(docx, file, internal_dir = internal_dir)
embed_file(docx, file, internal_dir = internal_dir)
}
}
return(docx)
@@ -18,18 +21,22 @@ embed_files <- function(docx, files, internal_dir = NULL) {
embed_file <- function(docx, file, content_type = guess_type(file),
internal_dir = NULL) {
if (!is.null(internal_dir) &&
!dir.exists(file.path(docx$package_dir, internal_dir)))
!dir.exists(file.path(docx$package_dir, internal_dir))) {
dir.create(file.path(docx$package_dir, internal_dir), recursive = TRUE)
}

file.copy(file,
to = do.call(file.path,
as.list(
c(docx$package_dir, internal_dir, basename(file)))
))
to = do.call(
file.path,
as.list(
c(docx$package_dir, internal_dir, basename(file))
)
)
)

extension <- tools::file_ext(file)
docx$content_type$add_ext(extension, content_type)
#docx$content_type$save()
# docx$content_type$save()

rel <- docx$doc_obj$relationship()
new_rid <- sprintf("rId%.0f", rel$get_next_id())


+ 1
- 1
R/officer-modify_style.R View File

@@ -4,7 +4,7 @@
#' @importFrom xml2 read_xml xml_find_first xml_add_child xml_set_attrs
#' write_xml
add_to_style <- function(docx, style_id, name, attrs = NULL, where = c("both", "rPr", "pPr", "top")) {
where = match.arg(where)
where <- match.arg(where)
docx <- to_docx(docx)
name <- prepend_ns(name)
if (!is.null(attrs)) names(attrs) <- prepend_ns(names(attrs))


+ 2
- 1
R/pandocoml.R View File

@@ -17,7 +17,8 @@ md_to_openxml <- function(text, simplify = TRUE,
oml <- (
xml_find_first(
read_xml(unz(tmpw, filename = "word/document.xml")),
"//w:body")
"//w:body"
)
)
if (remove_bookmarks) {
xml_remove(xml_find_all(oml, "//w:bookmarkStart | //w:bookmarkEnd"))


+ 2
- 4
R/preprocessor.R View File

@@ -20,18 +20,16 @@
#' @importFrom yaml write_yaml
#' @export
#' @examples
#'
#'
#' make_preknitter(wrappers = list(htmlcommentwrap, latexwrap))
#'
make_preknitter <- function(wrappers = list()) {

pre_knit <- function(input, ...) {
render_env <- get_parent_env_with("knit_input")
pre_knit_input <- get("knit_input", envir = render_env)
intermediates_loc <- get("intermediates_loc", envir = render_env)

rmd_text <- readfile(input)
rmd <- wrap_code(rmd_text, wrappers = wrappers)
rmd <- wrap_code(rmd_text, wrappers = wrappers)

codefile <- intermediates_loc(
file_with_meta_ext(basename(input), "codelist", "yml")


+ 39
- 32
R/redoc.R View File

@@ -29,13 +29,15 @@
#' @importFrom knitr knit_print knit_global opts_chunk opts_knit
#' @export
redoc <- function(highlight_outputs = TRUE, wrap = 80,
margins = NULL, line_numbers = NULL,
comment_author = NULL, keep_md = FALSE,
wrappers = list(htmlcommentwrap, latexwrap,
rawblockwrap, rawspanwrap,
cmwrap, citationwrap),
diagnostics = TRUE,
...) {
margins = NULL, line_numbers = NULL,
comment_author = NULL, keep_md = FALSE,
wrappers = list(
htmlcommentwrap, latexwrap,
rawblockwrap, rawspanwrap,
cmwrap, citationwrap
),
diagnostics = TRUE,
...) {

# Make a function to pre-process the Rmd file

@@ -46,17 +48,22 @@ redoc <- function(highlight_outputs = TRUE, wrap = 80,
pandoc <- rmarkdown::pandoc_options(
to = "docx+empty_paragraphs",
from = rmarkdown::from_rmarkdown(extensions = md_extensions),
args = c("--lua-filter",
system.file("lua-filters", "protect-empty.lua",
package = "redoc"))
args = c(
"--lua-filter",
system.file("lua-filters", "protect-empty.lua",
package = "redoc"
)
)
)

post_processor <-
function(metadata, input_file, output_file, clean, verbose) {
docx <- officer::read_docx(output_file)

render_env <- get_parent_env_with(c("intermediates", "intermediates_loc",
"knit_input", "original_input"))
render_env <- get_parent_env_with(c(
"intermediates", "intermediates_loc",
"knit_input", "original_input"
))

original_rmd_input <- get("original_input", envir = render_env)
renv_intermediates <- get("intermediates", envir = render_env)
@@ -68,22 +75,23 @@ redoc <- function(highlight_outputs = TRUE, wrap = 80,
)
codelist <- read_yaml(codefile)

embed_files(docx, c(original_rmd_input, renv_intermediates),
internal_dir = "redoc")

roundtrip_rmd <- dedoc(
output_file,
to = file_with_meta_ext(
basename(original_rmd_input), "roundtrip", "Rmd"
),
dir = renv_intermediates_dir,
wrap = wrap,
overwrite = TRUE,
orig_codefile = codefile
)
embed_files(docx, c(original_rmd_input, renv_intermediates),
internal_dir = "redoc"
)

add_intermediates(roundtrip_rmd)
embed_files(docx, roundtrip_rmd, internal_dir = "redoc")
roundtrip_rmd <- dedoc(
output_file,
to = file_with_meta_ext(
basename(original_rmd_input), "roundtrip", "Rmd"
),
dir = renv_intermediates_dir,
wrap = wrap,
overwrite = TRUE,
orig_codefile = codefile
)

add_intermediates(roundtrip_rmd)
embed_files(docx, roundtrip_rmd, internal_dir = "redoc")

if (diagnostics) {
diag_file <- renv_intermediates_loc(
@@ -121,21 +129,20 @@ redoc <- function(highlight_outputs = TRUE, wrap = 80,
}

get_diagnostics <- function() {
pandoc_version = as.character(rmarkdown::pandoc_version())
session_info = sessioninfo::session_info()
pandoc_version <- as.character(rmarkdown::pandoc_version())
session_info <- sessioninfo::session_info()
if (requireNamespace("rstudioapi") &&
rstudioapi::isAvailable()) {
rstudioapi::isAvailable()) {
rstudio_info <- rstudioapi::versionInfo()[c("version", "mode")]
} else {
rstudio_info <- NULL
}
list(
redoc_version = as.list(
session_info$packages[session_info$packages$package == "redoc",]
session_info$packages[session_info$packages$package == "redoc", ]
),
pandoc_version = pandoc_version,
rstudio_info = rstudio_info,
session_info = session_info
)
}


+ 8
- 9
R/stri-utils.R View File

@@ -25,9 +25,8 @@ divwrap <- function(text, id, class = "redoc") {

#' @importFrom stringi stri_join
spanwrap <- function(text, id, class = "redoc") {
# stri_join("[\n", text, "\n]{class=\"", class, "\" id=\"", id, "\"}")
# stri_join("[\n", text, "\n]{class=\"", class, "\" id=\"", id, "\"}")
stri_join("<span class=\"", class, "\" id=\"", id, "\">", text, "</span>")

}

#' Get the line number of the first fixed match
@@ -36,13 +35,13 @@ spanwrap <- function(text, id, class = "redoc") {
#' stri_count_fixed
stri_lineno_first_fixed <- function(text, pattern) {
loc <- stri_locate_first_fixed(text, pattern)
pre <- stri_sub(text, from = 1L, to = loc[,1] - 1)
pre <- stri_sub(text, from = 1L, to = loc[, 1] - 1)
as.integer(stri_count_lines(pre))
}

stri_count_lines <- function(text) {
text <- normalize_newlines(text)
stri_count_fixed(text, '\n') + 1
stri_count_fixed(text, "\n") + 1
}

#' @importFrom stringi stri_locate_all_fixed stri_replace_all_fixed
@@ -60,7 +59,7 @@ get_prior_empty_line_loc <- function(text, line) {
if (line > length(line_locs)) {
return(stri_length(text) + 1)
}
empty_locs <- rbind(c(0,0), stri_locate_all_regex(text, "(?s)\n\\h?\n")[[1]])
empty_locs <- rbind(c(0, 0), stri_locate_all_regex(text, "(?s)\n\\h?\n")[[1]])
empty_loc <- max(empty_locs[empty_locs <= line_locs[line]])
empty_loc
}
@@ -76,15 +75,15 @@ insert_at_prior_empty_line <- function(text, insertion, line) {
}

normalize_newlines <- function(text) {
stri_replace_all_fixed(text, c('\r\n', '\n\r', '\r'), '\n',
vectorize_all = FALSE)
stri_replace_all_fixed(text, c("\r\n", "\n\r", "\r"), "\n",
vectorize_all = FALSE
)
}

remove_extra_newlines <- function(text) {
stri_replace_all_regex(text, '[\n\r]{2,}', '\n\n')
stri_replace_all_regex(text, "[\n\r]{2,}", "\n\n")
}

last <- function(x) {
x[length(x)]
}


+ 34
- 21
R/utils.R View File

@@ -20,36 +20,45 @@ readfile <- function(x) {

file_with_meta_ext <- function(file, meta_ext, ext = tools::file_ext(file)) {
paste(tools::file_path_sans_ext(file),
".", meta_ext, ".", ext, sep = "")
".", meta_ext, ".", ext,
sep = ""
)
}

get_parent_env_with <- function(var_names) {
for (frame in rev(sys.frames())[-1]) {
present <- all(vapply(
var_names, exists, logical(1), envir = frame, inherits = FALSE
var_names, exists, logical(1),
envir = frame, inherits = FALSE
))
if (present) return(frame)
}
stop("No parent environment found with ",
paste(var_names, collapse = ", "))
stop(
"No parent environment found with ",
paste(var_names, collapse = ", ")
)
}

add_intermediates <- function(new_intermediates) {
render_env <- get_parent_env_with(c("intermediates", "intermediates_loc",
"knit_input"))
render_env <- get_parent_env_with(c(
"intermediates", "intermediates_loc",
"knit_input"
))
old_intermediates <- get("intermediates", envir = render_env)
assign("intermediates",
c(old_intermediates, new_intermediates),
envir = render_env)
c(old_intermediates, new_intermediates),
envir = render_env
)
}

list_subset <- function(list, ...) {
filters <- list(...)
for (i in seq_along(filters)) {
list <- Filter(list,
f = function(x) {
x[[names(filters)[i]]] == filters[[i]]
})
f = function(x) {
x[[names(filters)[i]]] == filters[[i]]
}
)
}
return(list)
}
@@ -70,22 +79,25 @@ list_subset <- function(list, ...) {
#' ast <- pandoc_ast(redoc_example_docx())
pandoc_ast <- function(file, from = NULL, tolist = TRUE) {
tmp <- tempfile()
if (is.null(from) && tools::file_ext(file) == "Rmd") from = "markdown"
rmarkdown::pandoc_convert(input = normalizePath(file),
to = "json",
from = from,
output = tmp)
if (tolist)
if (is.null(from) && tools::file_ext(file) == "Rmd") from <- "markdown"
rmarkdown::pandoc_convert(
input = normalizePath(file),
to = "json",
from = from,
output = tmp
)
if (tolist) {
return(jsonlite::fromJSON(tmp, simplifyVector = FALSE))
else
} else {
return(readfile(tmp))
}
}

#' @importFrom stringi stri_subset_regex
#' @importFrom utils unzip
get_files_from_zip <- function(zipfile, regex, exdir = ".",
junkpaths = TRUE, overwrite = TRUE) {
files <- unzip(zipfile, list = TRUE)$Name
files <- unzip(zipfile, list = TRUE)$Name
files <- stri_subset_regex(files, regex)
unzip(zipfile, files = files, exdir = exdir, overwrite = overwrite)
return(file.path(exdir, basename(zipfile)))
@@ -95,10 +107,11 @@ get_files_from_zip <- function(zipfile, regex, exdir = ".",
#' @importFrom utils unzip
get_con_from_zip <- function(zipfile, regex, open = "",
encoding = getOption("encoding")) {
files <- utils::unzip(zipfile, list = TRUE)$Name
files <- utils::unzip(zipfile, list = TRUE)$Name
file <- stri_subset_regex(files, regex)
if (length(file) != 1L)
if (length(file) != 1L) {
stop("regex matches ", length(file), " files. Only 1 allowed")
}
unz(zipfile, files, open, encoding)
}



+ 72
- 49
R/wrap.R View File

@@ -45,23 +45,28 @@ hide_chunks <- function(rmd) {
)
(?=(\n|$))"

label = "codechunk"
label <- "codechunk"

counter <- 0
chunks <- lapply(
stri_extract_all_regex(rmd$text, chunk_regex)[[1]],
function(x) {
counter <<- counter + 1
list(code = x,
label = label,
type = "block",
name = stri_join(prefix, label, "-", counter))
})
list(
code = x,
label = label,
type = "block",
name = stri_join(prefix, label, "-", counter)
)
}
)
for (i in seq_along(chunks)) {
chunks[[i]]$lineno <- stri_lineno_first_fixed(rmd$text, chunks[[i]]$code)
rmd$text <- stri_replace_first_fixed(rmd$text,
chunks[[i]]$code,
brkt(chunks[[i]]$name))
rmd$text <- stri_replace_first_fixed(
rmd$text,
chunks[[i]]$code,
brkt(chunks[[i]]$name)
)
}
rmd$code <- c(rmd$code, chunks)
rmd
@@ -69,24 +74,29 @@ hide_chunks <- function(rmd) {

hide_inlines <- function(rmd) {
inline_regex <- "(?<!(^|\n)``)`r[ #](?:[^`]+)\\s*`"
label = "inlinecode"
label <- "inlinecode"

counter <- 0
inlines <- lapply(
stri_extract_all_regex(rmd$text, inline_regex)[[1]],
function(x) {
counter <<- counter + 1
list(code = x,
label = label,
type = "inline",
name = stri_join(prefix, label, "-", counter))
})
list(
code = x,
label = label,
type = "inline",
name = stri_join(prefix, label, "-", counter)
)
}
)

for (i in seq_along(inlines)) {
inlines[[i]]$lineno <- stri_lineno_first_fixed(rmd$text, inlines[[i]]$code)
rmd$text <- stri_replace_first_fixed(rmd$text,
inlines[[i]]$code,
brkt(inlines[[i]]$name))
rmd$text <- stri_replace_first_fixed(
rmd$text,
inlines[[i]]$code,
brkt(inlines[[i]]$name)
)
}
rmd$code <- c(rmd$code, inlines)
rmd
@@ -95,8 +105,8 @@ hide_inlines <- function(rmd) {

#' @importFrom stringi stri_detect_regex
hide_yaml <- function(rmd) {
yaml.begin = "^---\\h*$"
yaml.end = "^(---|\\.\\.\\.)\\h*$"
yaml.begin <- "^---\\h*$"
yaml.end <- "^(---|\\.\\.\\.)\\h*$"
lines <- reline(rmd$text)

yamls <- list()
@@ -133,21 +143,24 @@ hide_yaml <- function(rmd) {
}
}
}
label = "yaml"
label <- "yaml"

counter <- 0
yamls <- lapply(yamls, function(x) {
counter <<- counter + 1
list(code = x,
label = label,
type = "block",
name = stri_join(prefix, label, "-", counter))
list(
code = x,
label = label,
type = "block",
name = stri_join(prefix, label, "-", counter)
)
})
if (!is.null(yaml_header)) {
yaml_header <- list(list(code = yaml_header,
label = "yamlheader",
type = "header",
name = stri_join(prefix, "yamlheader")
yaml_header <- list(list(
code = yaml_header,
label = "yamlheader",
type = "header",
name = stri_join(prefix, "yamlheader")
))
yamls <- c(yamls, yaml_header)
}
@@ -155,9 +168,11 @@ hide_yaml <- function(rmd) {

for (i in seq_along(yamls)) {
yamls[[i]]$lineno <- stri_lineno_first_fixed(rmd$text, yamls[[i]]$code)
rmd$text <- stri_replace_first_fixed(rmd$text,
yamls[[i]]$code,
brkt(yamls[[i]]$name))
rmd$text <- stri_replace_first_fixed(
rmd$text,
yamls[[i]]$code,
brkt(yamls[[i]]$name)
)
}
rmd$code <- c(rmd$code, yamls)
rmd
@@ -167,40 +182,48 @@ hide_yaml <- function(rmd) {

#' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
unhide_yaml <- function(rmd) {

yamls <- list_subset(rmd$code, label = "yaml")
if (length(yamls)) {
rmd$text <- stri_replace_all_fixed(rmd$text,
brkt(subel(yamls, "name")),
divwrap(subel(yamls, "code"), subel(yamls, "name")),
vectorize_all = FALSE)
brkt(subel(yamls, "name")),
divwrap(subel(yamls, "code"), subel(yamls, "name")),
vectorize_all = FALSE
)
}

yaml_header <- list_subset(rmd$code, label = "yamlheader")
rmd$text <- stri_replace_first_fixed(rmd$text,
brkt(subel(yaml_header, "name")),
subel(yaml_header, "code"))
rmd$text <- stri_replace_first_fixed(
rmd$text,
brkt(subel(yaml_header, "name")),
subel(yaml_header, "code")
)
rmd
}

#' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
unhide_inlines <- function(rmd) {
inlines <- list_subset(rmd$code, label = "inlinecode")
inlines <- list_subset(rmd$code, label = "inlinecode")
rmd$text <- stri_replace_all_fixed(rmd$text,
brkt(subel(inlines, "name")),
spanwrap(subel(inlines, "code"),
subel(inlines, "name")),
vectorize_all = FALSE)
brkt(subel(inlines, "name")),
spanwrap(
subel(inlines, "code"),
subel(inlines, "name")
),
vectorize_all = FALSE
)
rmd
}

#' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
unhide_chunks <- function(rmd) {
chunks <- list_subset(rmd$code, label = "codechunk")
chunks <- list_subset(rmd$code, label = "codechunk")
rmd$text <- stri_replace_all_fixed(rmd$text,
brkt(subel(chunks, "name")),
divwrap(subel(chunks, "code"),
subel(chunks, "name")),
vectorize_all = FALSE)
brkt(subel(chunks, "name")),
divwrap(
subel(chunks, "code"),
subel(chunks, "name")
),
vectorize_all = FALSE
)
rmd
}

+ 0
- 1
man/make_preknitter.Rd View File

@@ -31,5 +31,4 @@ this pre-processed document.
\examples{

make_preknitter(wrappers = list(htmlcommentwrap, latexwrap))

}

+ 7
- 5
tests/spelling.R View File

@@ -1,5 +1,7 @@
if (requireNamespace('spelling', quietly = TRUE))
spelling::spell_check_test(vignettes = TRUE,
error = FALSE,
skip_on_cran = TRUE)

if (requireNamespace("spelling", quietly = TRUE)) {
spelling::spell_check_test(
vignettes = TRUE,
error = FALSE,
skip_on_cran = TRUE
)
}

+ 2
- 2
tests/testthat/test-roundtrip.R View File

@@ -65,7 +65,7 @@ test_that("R Markdown is preserved in the roundtrip", {
tar.banner = "Original", cur.banner = "Current"
)
cat(as.character(dast),
file = file.path("artifacts", "diffs", "roundtrip-ast.html"))
file = file.path("artifacts", "diffs", "roundtrip-ast.html")
)
expect_equal(orig_ast, roundtrip_ast)

})

Loading…
Cancel
Save