r
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

244 lines
6.7KB

  1. #' Wrap and store code for un-knitting
  2. #'
  3. #' @return list with elements `text` and `code`. `text` the text provided with has code elements
  4. #' wrapped in names spans and divs with unique ids. `code` is a list of those code chunks, with ids
  5. #' as names.
  6. #' with names of the form `redoc-type-number`
  7. #' @param rmd_text R Markdown text as a length-1 character vector
  8. #' @param wrappers a list of functions to further process the text. They will
  9. #' be passed a list of `text` and `code` and should return the same with
  10. #' text processed and additional elements appended to `code`. R code and YAML are temporarily replaced with
  11. #' `[[redoc-type-number]]` so additional wrappers don't mangle them. Chunks in text should generally we wrapped in
  12. #' Pandoc spans and divs with attribute `custom-style="redoc-TYPE-NUMBER`.
  13. #' @noRd
  14. wrap_code <- function(text, wrappers = list()) {
  15. rmd <- list(text = text, code = list())
  16. rmd <- hide_chunks(rmd)
  17. rmd <- hide_inlines(rmd)
  18. rmd <- hide_yaml(rmd)
  19. for (wrapper in wrappers) {
  20. rmd <- wrapper(rmd)
  21. }
  22. rmd <- unhide_yaml(rmd)
  23. rmd <- unhide_inlines(rmd)
  24. rmd <- unhide_chunks(rmd)
  25. rmd$code <- sort_by(rmd$code, "lineno")
  26. names(rmd$code) <- unlist(subel(rmd$code, "name"))
  27. class(rmd$code) <- "codelist"
  28. return(rmd)
  29. }
  30. prefix <- "redoc-"
  31. #' @importFrom stringi stri_extract_all_regex
  32. hide_chunks <- function(rmd) {
  33. chunk_regex <- "(?sx)
  34. (?<=(^|\n))
  35. (?:
  36. [\t >]*```+\\h*\\{.*?\\}.*?[\t >]*```+\\h* |
  37. (^|\n)\\h*<<[^\\}](.+)[^\\{]>>\\h*(\n|$)
  38. )
  39. (?=(\n|$))"
  40. label <- "codechunk"
  41. counter <- 0
  42. chunk_text <- stri_extract_all_regex(rmd$text, chunk_regex)[[1]]
  43. if (length(chunk_text) == 1 && is.na(chunk_text)) {
  44. chunks <- NULL
  45. } else {
  46. chunks <- lapply(
  47. stri_extract_all_regex(rmd$text, chunk_regex)[[1]],
  48. function(x) {
  49. counter <<- counter + 1
  50. list(
  51. code = x,
  52. label = label,
  53. type = "block",
  54. name = stri_join(prefix, label, "-", counter)
  55. )
  56. }
  57. )
  58. for (i in seq_along(chunks)) {
  59. chunks[[i]]$lineno <- stri_lineno_first_fixed(rmd$text, chunks[[i]]$code)
  60. rmd$text <- stri_replace_first_fixed(
  61. rmd$text,
  62. chunks[[i]]$code,
  63. brkt(chunks[[i]]$name)
  64. )
  65. }
  66. }
  67. rmd$code <- c(rmd$code, chunks)
  68. rmd
  69. }
  70. hide_inlines <- function(rmd) {
  71. inline_regex <- "(?<!(^|\n)``)`r[ #](?:[^`]+)\\s*`"
  72. label <- "inlinecode"
  73. counter <- 0
  74. inline_text <- stri_extract_all_regex(rmd$text, inline_regex)[[1]]
  75. if (length(inline_text) == 1 && is.na(inline_text)) {
  76. inlines <- NULL
  77. } else {
  78. inlines <- lapply(
  79. inline_text,
  80. function(x) {
  81. counter <<- counter + 1
  82. list(
  83. code = x,
  84. label = label,
  85. type = "inline",
  86. name = stri_join(prefix, label, "-", counter)
  87. )
  88. }
  89. )
  90. for (i in seq_along(inlines)) {
  91. inlines[[i]]$lineno <- stri_lineno_first_fixed(rmd$text, inlines[[i]]$code)
  92. rmd$text <- stri_replace_first_fixed(
  93. rmd$text,
  94. inlines[[i]]$code,
  95. brkt(inlines[[i]]$name)
  96. )
  97. }
  98. }
  99. rmd$code <- c(rmd$code, inlines)
  100. rmd
  101. }
  102. #' @importFrom stringi stri_detect_regex
  103. hide_yaml <- function(rmd) {
  104. yaml.begin <- "^---\\h*$"
  105. yaml.end <- "^(---|\\.\\.\\.)\\h*$"
  106. lines <- reline(rmd$text)
  107. yamls <- list()
  108. yaml_header <- NULL
  109. current_yaml <- NULL
  110. in_yaml <- FALSE
  111. at_start <- TRUE
  112. for (i in seq_along(lines)) {
  113. if (!in_yaml) {
  114. if (stri_detect_regex(lines[i], yaml.begin)) {
  115. in_yaml <- TRUE
  116. current_yaml <- c(current_yaml, lines[i])
  117. }
  118. if (at_start & !in_yaml) {
  119. if (stri_detect_regex(lines[i], "^\\h*$", negate = TRUE)) {
  120. at_start <- FALSE
  121. }
  122. }
  123. } else if (in_yaml) {
  124. if (stri_detect_regex(lines[i], yaml.end)) {
  125. in_yaml <- FALSE
  126. current_yaml <- c(current_yaml, lines[i])
  127. yaml_block <- stri_join(unlist(current_yaml), collapse = "\n")
  128. if (at_start) {
  129. yaml_header <- yaml_block
  130. at_start <- FALSE
  131. } else {
  132. yamls <- c(yamls, list(yaml_block))
  133. }
  134. current_yaml <- list()
  135. next
  136. } else {
  137. current_yaml <- c(current_yaml, lines[i])
  138. }
  139. }
  140. }
  141. label <- "yaml"
  142. counter <- 0
  143. yamls <- lapply(yamls, function(x) {
  144. counter <<- counter + 1
  145. list(
  146. code = x,
  147. label = label,
  148. type = "block",
  149. name = stri_join(prefix, label, "-", counter)
  150. )
  151. })
  152. if (!is.null(yaml_header)) {
  153. yaml_header <- list(list(
  154. code = yaml_header,
  155. label = "yamlheader",
  156. type = "header",
  157. name = stri_join(prefix, "yamlheader")
  158. ))
  159. yamls <- c(yamls, yaml_header)
  160. }
  161. for (i in seq_along(yamls)) {
  162. yamls[[i]]$lineno <- stri_lineno_first_fixed(rmd$text, yamls[[i]]$code)
  163. rmd$text <- stri_replace_first_fixed(
  164. rmd$text,
  165. yamls[[i]]$code,
  166. brkt(yamls[[i]]$name)
  167. )
  168. }
  169. rmd$code <- c(rmd$code, yamls)
  170. rmd
  171. }
  172. #' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
  173. unhide_yaml <- function(rmd) {
  174. yamls <- list_subset(rmd$code, label = "yaml")
  175. if (length(yamls)) {
  176. rmd$text <- stri_replace_all_fixed(rmd$text,
  177. brkt(subel(yamls, "name")),
  178. divwrap(subel(yamls, "code"), subel(yamls, "name")),
  179. vectorize_all = FALSE
  180. )
  181. }
  182. yaml_header <- list_subset(rmd$code, label = "yamlheader")
  183. rmd$text <- stri_replace_first_fixed(
  184. rmd$text,
  185. brkt(subel(yaml_header, "name")),
  186. subel(yaml_header, "code")
  187. )
  188. rmd
  189. }
  190. #' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
  191. unhide_inlines <- function(rmd) {
  192. inlines <- list_subset(rmd$code, label = "inlinecode")
  193. if (length(inlines)) {
  194. rmd$text <- stri_replace_all_fixed(rmd$text,
  195. brkt(subel(inlines, "name")),
  196. spanwrap(
  197. subel(inlines, "code"),
  198. subel(inlines, "name")
  199. ),
  200. vectorize_all = FALSE
  201. )
  202. }
  203. rmd
  204. }
  205. #' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
  206. unhide_chunks <- function(rmd) {
  207. chunks <- list_subset(rmd$code, label = "codechunk")
  208. if (length(chunks)) {
  209. rmd$text <- stri_replace_all_fixed(rmd$text,
  210. brkt(subel(chunks, "name")),
  211. divwrap(
  212. subel(chunks, "code"),
  213. subel(chunks, "name")
  214. ),
  215. vectorize_all = FALSE
  216. )
  217. }
  218. rmd
  219. }