1
#' Spin goat's hair into wool
2
#'
3
#' This function takes a specially formatted R script and converts it to a
4
#' literate programming document. By default normal text (documentation) should
5
#' be written after the roxygen comment (\code{#'}) and code chunk options are
6
#' written after \code{#+} or \code{#-} or \code{# ----} or any of these
7
#' combinations replacing \code{#} with \code{--}.
8
#'
9
#' Obviously the goat's hair is the original R script, and the wool is the
10
#' literate programming document (ready to be knitted).
11
#' @param hair Path to the R script. The script must be encoded in UTF-8 if it
12
#'   contains multibyte characters.
13
#' @param knit Logical; whether to compile the document after conversion.
14
#' @param report Logical; whether to generate a report for \file{Rmd},
15
#'   \file{Rnw} and \file{Rtex} output. Ignored if \code{knit = FALSE}.
16
#' @param text A character vector of code, as an alternative way to provide the
17
#'   R source. If \code{text} is not \code{NULL}, \code{hair} will be ignored.
18
#' @param envir Environment for \code{\link{knit}()} to evaluate the code.
19
#' @param format Character; the output format. The default is R Markdown.
20
#' @param doc A regular expression to identify the documentation lines; by
21
#'   default it follows the roxygen convention, but it can be customized, e.g.
22
#'   if you want to use \code{##} to denote documentation, you can use
23
#'   \code{'^##\\\\s*'}.
24
#' @param inline A regular expression to identify inline R expressions; by
25
#'   default, code of the form \code{\{\{code\}\}} on its own line is treated as
26
#'   an inline expression.
27
#' @param comment A pair of regular expressions for the start and end delimiters
28
#'   of comments; the lines between a start and an end delimiter will be
29
#'   ignored. By default, the delimiters are \verb{/*} at the beginning of a
30
#'   line, and \verb{*/} at the end, following the convention of C comments.
31
#' @param precious logical: whether intermediate files (e.g., \code{.Rmd} files
32
#'   when \code{format} is \code{"Rmd"}) should be preserved. The default is
33
#'   \code{FALSE} if \code{knit} is \code{TRUE} and the input is a file.
34
#' @author Yihui Xie, with the original idea from Richard FitzJohn (who named it
35
#'   as \code{sowsear()} which meant to make a silk purse out of a sow's ear)
36
#' @return If \code{text} is \code{NULL}, the path of the final output document,
37
#'   otherwise the content of the output.
38
#' @note If the output format is Rnw and no document class is specified in
39
#'   roxygen comments, this function will automatically add the \code{article}
40
#'   class to the LaTeX document so that it is complete and can be compiled. You
41
#'   can always specify the document class and other LaTeX settings in roxygen
42
#'   comments manually.
43
#'
44
#'   When the output format is Rmd, it is compiled to HTML via
45
#'   \code{\link{knit2html}()}, which uses R Markdown v1 instead of v2. If you
46
#'   want to use the latter, you should call
47
#'   \code{rmarkdown::\link[rmarkdown]{render}()} instead.
48
#' @export
49
#' @seealso \code{\link{stitch}} (feed a template with an R script)
50
#' @references \url{https://yihui.org/knitr/demo/stitch/}
51
spin = function(
52
  hair, knit = TRUE, report = TRUE, text = NULL, envir = parent.frame(),
53
  format = c('Rmd', 'Rnw', 'Rhtml', 'Rtex', 'Rrst'),
54
  doc = "^#+'[ ]?", inline = '^[{][{](.+)[}][}][ ]*$',
55
  comment = c("^[# ]*/[*]", "^.*[*]/ *$"), precious = !knit && is.null(text)
56
) {
57

58 1
  format = match.arg(format)
59 1
  x = if (nosrc <- is.null(text)) read_utf8(hair) else split_lines(text)
60 1
  stopifnot(length(comment) == 2L)
61 1
  c1 = grep(comment[1], x); c2 = grep(comment[2], x)
62 1
  if (length(c1) != length(c2))
63 0
    stop('comments must be put in pairs of start and end delimiters')
64
  # remove comments
65 0
  if (length(c1)) x = x[-unique(unlist(mapply(seq, c1, c2, SIMPLIFY = FALSE)))]
66

67
  # remove multiline string literals and symbols (note that this ignores lines with spaces at their
68
  # beginnings, assuming doc and inline regex don't match these lines anyway)
69 1
  parsed_data = getParseData(parse(text = x, keep.source = TRUE))
70 1
  is_matchable = seq_along(x) %in% unique(parsed_data[parsed_data$col1 == 1, 'line1'])
71

72
  # .Rmd needs to be treated specially
73 1
  p = if (identical(tolower(format), 'rmd')) .fmt.rmd(x) else .fmt.pat[[tolower(format)]]
74

75
  # turn {{expr}} into inline expressions, e.g. `r expr` or \Sexpr{expr}
76 1
  if (any(i <- is_matchable & grepl(inline, x))) x[i] = gsub(inline, p[4], x[i])
77

78 1
  r = rle((is_matchable & grepl(doc, x)) | i)  # inline expressions are treated as doc instead of code
79 1
  n = length(r$lengths); txt = vector('list', n); idx = c(0L, cumsum(r$lengths))
80 1
  p1 = gsub('\\{', '\\\\{', paste0('^', p[1L], '.*', p[2L], '$'))
81

82 1
  for (i in seq_len(n)) {
83 1
    block = x[seq(idx[i] + 1L, idx[i + 1])]
84 1
    txt[[i]] = if (r$values[i]) {
85
      # normal text; just strip #'
86 1
      sub(doc, '', block)
87
    } else {
88
      # R code; #+/- indicates chunk options
89 1
      block = strip_white(block) # rm white lines in beginning and end
90 0
      if (!length(block)) next
91 1
      if (length(opt <- grep(rc <- '^(#|--)+(\\+|-| ----+| @knitr)', block))) {
92 0
        block[opt] = paste0(p[1L], gsub(paste0(rc, '\\s*|-*\\s*$'), '', block[opt]), p[2L])
93
        # close each chunk if there are multiple chunks in this block
94 0
        if (any(opt > 1)) {
95 0
          j = opt[opt > 1]
96 0
          block[j] = paste(p[3L], block[j], sep = '\n')
97
        }
98
      }
99 1
      if (!grepl(p1, block[1L])) {
100 1
        block = c(paste0(p[1L], p[2L]), block)
101
      }
102 1
      c('', block, p[3L], '')
103
    }
104
  }
105

106 1
  txt = unlist(txt)
107
  # make it a complete TeX document if document class not specified
108 1
  if (report && format %in% c('Rnw', 'Rtex') && !grepl('^\\s*\\\\documentclass', txt)) {
109 0
    txt = c('\\documentclass{article}', '\\begin{document}', txt, '\\end{document}')
110
  }
111 1
  if (nosrc) {
112 1
    outsrc = with_ext(hair, format)
113 1
    write_utf8(txt, outsrc)
114 1
    txt = NULL
115 0
  } else outsrc = NULL
116 1
  if (!knit) return(txt %n% outsrc)
117

118 0
  out = if (report) {
119 0
    if (format == 'Rmd') {
120 0
      knit2html(outsrc, text = txt, envir = envir)
121 0
    } else if (!is.null(outsrc) && (format %in% c('Rnw', 'Rtex'))) {
122 0
      knit2pdf(outsrc, envir = envir)
123
    }
124 0
  } else knit(outsrc, text = txt, envir = envir)
125

126 0
  if (!precious && !is.null(outsrc)) file.remove(outsrc)
127 0
  invisible(out)
128
}
129

130
.fmt.pat = list(
131
  rnw = c('<<', '>>=', '@', '\\\\Sexpr{\\1}'),
132
  rhtml = c('<!--begin.rcode ', '', 'end.rcode-->', '<!--rinline \\1 -->'),
133
  rtex = c('% begin.rcode ', '', '% end.rcode', '\\\\rinline{\\1}'),
134
  rrst = c('.. {r ', '}', '.. ..', ':r:`\\1`')
135
)
136

137
# determine how many backticks we need to wrap code blocks and inline code
138
.fmt.rmd = function(x) {
139 1
  x = one_string(x)
140 1
  l = attr(gregexpr('`+', x)[[1]], 'match.length')
141 1
  l = max(l, 0)
142 1
  if (length(l) > 0) {
143 1
    i = highr:::spaces(l + 1, '`')
144 1
    b = highr:::spaces(max(l + 1, 3), '`')
145
  } else {
146 0
    i = '`'
147 0
    b = '```'
148
  }
149 1
  c(paste0(b, '{r '), '}', b, paste0(i, 'r \\1 ', i))
150
}
151

152
#' Spin a child R script
153
#'
154
#' This function is similar to \code{\link{knit_child}()} but is used in R
155
#' scripts instead. When the main R script is not called via
156
#' \code{\link{spin}()}, this function simply executes the child script via
157
#' \code{\link{sys.source}()}, otherwise it calls \code{\link{spin}()} to spin
158
#' the child script into a source document, and uses \code{\link{knit_child}()}
159
#' to compile it. You can call this function in R code, or using the syntax of
160
#' inline R expressions in \code{\link{spin}()} (e.g.
161
#' \code{{{knitr::spin_child('script.R')}}}).
162
#' @param input Filename of the input R script.
163
#' @param format Passed to \code{format} in \code{spin()}. If not
164
#'   provided, it will be guessed from the current knitting process.
165
#' @return A character string of the knitted R script.
166
#' @export
167
spin_child = function(input, format) {
168 0
  if (!isTRUE(getOption('knitr.in.progress')))
169 0
    return(sys.source(input, parent.frame()))
170 0
  fmt = if (missing(format)) {
171 0
    if (is.null(fmt <- out_format()))
172 0
      stop('spin_child() must be called in a knitting process')
173 0
    .spin.fmt = c(
174 0
      'latex' = 'Rnw', 'sweave' = 'Rnw', 'listings' = 'Rnw',
175 0
      'html' = 'Rhtml', 'markdown' = 'Rmd'
176
    )
177 0
    if (is.na(fmt <- .spin.fmt[fmt]))
178 0
      stop('the document format ', fmt, ' is not supported yet')
179 0
    fmt
180 0
  } else format
181 0
  asis_output(knit_child(
182 0
    text = spin(text = read_utf8(input), knit = FALSE, report = FALSE, format = fmt),
183 0
    quiet = TRUE
184
  ))
185
}

Read our documentation on viewing source code .

Loading