Attachment 'Rd2moin.R'
Download 1 #' Rd Converter for \special{MoinMoin} Markup
2 #'
3 #' This function takes (or obtains) output of the \code{\link[tools:parse_Rd]{parse_Rd}} function and produces a help page in \special{MoinMoin} markup. It uses internal functions from \code{\link[tools:tools]{tools}}, so these are subject to change. See \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
4 #' @param Rd an parsed Rd object to use as input, or a file path for an Rd file.
5 #' @param out a filename or connection object to which to write the output. names to be applied to \code{x}, if unnamed, or to replace existing names.
6 #' @param append a logical value indicating whether the output file should be openned in append or write mode.
7 #' @param package the package to list in the output.
8 #' @param defines string(s) to use in #ifdef tests.
9 #' @param stages at which stage ("build", "install", or "render") should \\Sexpr macros be executed? See \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
10 #' @param outputEncoding see \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
11 #' @param fragment a logical value indicating if fragments of Rd files be accepted.See \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
12 #' @param depth an integer indicating the heading level at which to start.
13 #' @param prepared a local value indicating if the Rd object supplied has aleardy been prepared for processing by \code{tools:::prepare_Rd()}.
14 #' @param ... additional parameters to pass to \code{tools:::prepare_Rd()} for use in parsing an Rd source. See \code{\link[tools:parse_Rd]{parse_Rd}}.
15 #' @author Ian Riley \email{ian@@riley.asia}
16 #' @return This function is executed to write a help page converted to \special{MoinMoin} markup. The value is the name of the output file (invisibly).
17 # @examples
18 # To come!
19 #' @export
20 Rd2moin <- function(Rd, out = "", append = FALSE, package = "", defines = .Platform$OS.type,
21 stages = "render", outputEncoding = "UTF-8", fragment = FALSE, depth = 1,
22 prepared = FALSE, ...) #!moin
23
24 {
25 #!moin TODO escape camelcase with !
26
27 code_quote = TRUE
28 fcodes <- c("l", "c", "r")
29
30 buffer <- character() # Lines to be written to con
31 # Newlines are treated as a separate input lines
32
33 # For tacking
34 linestart <- TRUE # At start of line?
35 dropBlank <- FALSE # Drop initial blank lines?
36 haveBlanks <- 0L # How many blank lines have just been written?
37 enumItem <- 0L # Last enumeration item number
38 inEqn <- FALSE # Should we do edits needed in an eqn?
39 sectionLevel <- depth #!moin Start from 1 form MoinMoin headings
40
41 startCapture <- function() {
42 save <- list(buffer=buffer, linestart=linestart, dropBlank=dropBlank,
43 haveBlanks=haveBlanks, enumItem=enumItem, inEqn=inEqn)
44 buffer <<- character()
45 linestart <<- TRUE
46 dropBlank <<- FALSE
47 haveBlanks <<- 0L
48 enumItem <<- 0L
49 inEqn <<- FALSE
50 save
51 }
52
53 endCapture <- function(saved) {
54 result <- buffer
55 buffer <<- saved$buffer
56 linestart <<- saved$linestart
57 dropBlank <<- saved$dropBlank
58 haveBlanks <<- saved$haveBlanks
59 enumItem <<- saved$enumItem
60 inEqn <<- saved$inEqn
61 result
62 }
63
64 ## for efficiency
65 WriteLines <-
66 if (outputEncoding == "UTF-8" ||
67 (outputEncoding == "" && l10n_info()[["UTF-8"]])) {
68 function(x, con, outputEncoding, ...) {
69 writeLines(x, con, useBytes = TRUE, ...)
70 }
71 } else {
72 function(x, con, outputEncoding, ...) {
73 x <- iconv(x, "UTF-8", outputEncoding, sub="byte", mark=FALSE)
74 writeLines(x, con, useBytes = TRUE, ...)
75 }
76 }
77
78 put <- function(...) {
79 txt <- paste0(..., collapse="")
80 trail <- grepl("\n$", txt)
81 # Convert newlines
82 txt <- strsplit(txt, "\n", fixed = TRUE)[[1L]]
83 if (dropBlank) {
84 while(length(txt) && grepl("^[[:space:]]*$", txt[1L]))
85 txt <- txt[-1L]
86 if (length(txt)) dropBlank <<- FALSE
87 }
88 if (!length(txt)) return()
89 haveBlanks <<- 0
90
91 if (linestart) buffer <<- c(buffer, txt)
92 else if (length(buffer)) {
93 buffer[length(buffer)] <<-
94 paste0(buffer[length(buffer)], txt[1L])
95 buffer <<- c(buffer, txt[-1L])
96 } else buffer <<- txt
97 linestart <<- trail
98 }
99
100 flushBuffer <- function() {
101 if (!length(buffer)) return()
102 if (length(buffer)) WriteLines(buffer, con, outputEncoding)
103 buffer <<- character()
104 linestart <<- TRUE
105 }
106
107 trim <- function(x) {
108 x <- psub1("^\\s*", "", x)
109 psub1("\\s*$", "", x)
110 }
111
112 unescape <- function(x) {
113 psub("(---|--)", "-", x)
114 }
115
116 tabExpand <- function (x) {
117 srcref <- attr(x, "srcref")
118 if (is.null(srcref))
119 start <- 0L
120 else start <- srcref[5L] - 1L
121 #.Call(C_doTabExpand, x, start) #!moin
122 # cannot call this outside `Tools`
123 # so the following replacement is used
124 fsub("\t", strrep(" ", start), x) #!moin
125 }
126
127 writeCode <- function(x) {
128 txt <- as.character(x)
129 if(inEqn) txt <- txt_eqn(txt)
130 txt <- fsub('"\\{"', '"{"', txt)
131 ## \dots gets left in noquote.Rd
132 txt <- fsub("\\dots", "...", txt) #!moin
133 put(txt)
134 }
135
136 # This function strips pending blank lines, then adds n new ones.
137 blankLine <- function(n = 1L) {
138 while (length(buffer) && grepl("^[[:blank:]]*$", buffer[length(buffer)]))
139 buffer <<- buffer[-length(buffer)]
140 flushBuffer()
141 if (n > haveBlanks) {
142 buffer <<- rep_len("", n - haveBlanks)
143 flushBuffer()
144 haveBlanks <<- n
145 }
146 dropBlank <<- TRUE
147 }
148
149 txt_eqn <- function(x) { #!moin this has not been tested from moin markup
150 x <- psub("\\\\(Alpha|Beta|Gamma|Delta|Epsilon|Zeta|Eta|Theta|Iota|Kappa|Lambda|Mu|Nu|Xi|Omicron|Pi|Rho|Sigma|Tau|Upsilon|Phi|Chi|Psi|Omega|alpha|beta|gamma|delta|epsilon|zeta|eta|theta|iota|kappa|lambda|mu|nu|xi|omicron|pi|rho|sigma|tau|upsilon|phi|chi|psi|omega|sum|prod|sqrt)", "\\1", x)
151 x <- psub("\\\\(dots|ldots)", "...", x)
152 x <- fsub("\\le", "<=", x)
153 x <- fsub("\\ge", ">=", x)
154 x <- fsub("\\infty", "Inf", x)
155 ## FIXME: are these needed?
156 x <- psub("\\\\(bold|strong|emph|var)\\{([^}]*)\\}", "\\2", x)
157 x <- psub("\\\\(code|samp)\\{([^}]*)\\}", "'\\2'", x)
158 x
159 }
160
161 writeDR <- function(block, tag) {
162 if (length(block) > 1L) {
163 put('## Not run:\n')
164 writeCodeBlock(block, tag)
165 blankLine(0L)
166 put('## End(Not run)\n')
167 } else {
168 put('## Not run: ')
169 writeCodeBlock(block, tag)
170 blankLine(0L)
171 }
172 }
173
174 writeQ <- function(block, tag, quote=tag)
175 {
176 if (quote == "\\sQuote") {
177 put("'"); writeContent(block, tag); put("'")
178 } else {
179 put("\""); writeContent(block,tag); put("\"")
180 }
181 }
182
183 tidy <- function(block) { #!moin
184 x <- paste(as.character(block), collapse="")
185 trimws(gsub("\n", "", x))
186 }
187
188 writeBlock <- function(block, tag, blocktag) {
189 switch(tag,
190 UNKNOWN =,
191 VERB =,
192 RCODE = writeCode(tabExpand(block)),
193 TEXT = {
194 if (blocktag == "\\command") put(block) #!moin
195 else put(escWw(unescape(tabExpand(block)))) #!moin
196 },
197 USERMACRO =,
198 "\\newcommand" =,
199 "\\renewcommand" =,
200 COMMENT = {},
201 LIST = writeContent(block, tag),
202 "\\describe" = {
203 blankLine(0L)
204 writeContent(block, tag)
205 blankLine()
206 },
207 "\\itemize" =,
208 "\\enumerate" = {
209 blankLine(0L)
210 enumItem0 <- enumItem
211 enumItem <<- 0L
212 dropBlank <<- TRUE
213 writeContent(block, tag)
214 blankLine()
215 enumItem <<- enumItem0
216 },
217 "\\code" = { #!moin
218 put(markup(type = ".monospace"))
219 writeContent(block, tag)
220 put(markup(type = ".monospace"))
221 },
222 "\\command" =,
223 "\\env" =,
224 "\\file" =,
225 "\\kbd" =,
226 "\\option" =,
227 "\\pkg" =,
228 "\\samp" = {
229 if(code_quote)
230 writeQ(block, tag, quote="\\sQuote")
231 else writeContent(block, tag)
232 },
233 "\\email" = if (length(block)) { #!moin
234 put(markup(tidy(block), "mailTo"))
235 },
236 "\\url" = if (length(block)) { #!moin
237 put(markup(tidy(block), "link"))
238 },
239 "\\href" = if (length(block[[1L]])) { #!moin
240 if (length(block[[2L]])) {
241 .url <- tidy(block)
242 names(.url) <- writeContent(block[[2L]], tag)
243 put(markup(.url, "linkNamed"))
244 } else {
245 put(markup(tidy(block), "link"))
246 }
247 },
248 "\\Sexpr" = put(as.character.Rd(block, deparse=TRUE)), #throws errors
249 "\\acronym" =,
250 "\\cite" =,
251 "\\dfn" =,
252 "\\special" =,
253 "\\var" = writeContent(block, tag),
254 "\\bold" =,
255 "\\strong" = { #!moin
256 put(markup(type = ".bold"))
257 writeContent(block, tag)
258 put(markup(type = ".bold"))
259 },
260 "\\emph" = { #!moin
261 put(markup(type = ".italic"))
262 writeContent(block, tag)
263 put(markup(type = ".italic"))
264 },
265 "\\sQuote" =,
266 "\\dQuote" = writeQ(block, tag),
267 "\\preformatted" = { #!moin
268 put(markup(type = ".verbBlockOpen"))
269 writeCodeBlock(block, tag)
270 put(markup(type = ".blockClose"))
271 },
272 "\\verb" = put(block),
273 "\\linkS4class" =,
274 "\\link" = put(block), #{ #!moin
275 #put(markup(type = ".linkOpen"))
276 #writeContent(block, tag)
277 #put(markup(type = ".linkClose"))
278 #},
279 "\\cr" = put(markup(type = ".newline")), #!moin
280 "\\dots" = put(markup("...", "monospace")), #!moin
281 "\\ldots" = put("..."),
282 "\\R" = put("R"),
283 "\\enc" = { #!moin untested from moin markup
284 ## Test to see if we can convert the encoded version
285 txt <- as.character(block[[1L]])
286 test <- iconv(txt, "UTF-8", outputEncoding, mark = FALSE)
287 txt <- if(!is.na(test)) txt else as.character(block[[2L]])
288 put(txt)
289 },
290 "\\eqn" = { #!moin untested from moin markup
291 block <- block[[length(block)]]
292 ## FIXME: treat 2 of 2 differently?
293 inEqn0 <- inEqn
294 inEqn <<- TRUE
295 writeContent(block, tag)
296 inEqn <<- inEqn0
297 },
298 "\\deqn" = { #!moin untested from moin markup
299 blankLine()
300 block <- block[[length(block)]]
301 save <- startCapture()
302 inEqn <<- TRUE
303 writeContent(block, tag)
304 eqn <- endCapture(save)
305 put(paste(eqn, collapse = "\n"))
306 blankLine()
307 },
308 "\\figure" = { #!moin untested from moin markup
309 blankLine()
310 save <- startCapture()
311 writeContent(block[[length(block)]], tag)
312 alt <- endCapture(save)
313 if (length(alt)) {
314 put(paste(alt, collapse = "\n"))
315 blankLine()
316 }
317 },
318 "\\tabular" = writeTabular(block),
319 "\\subsection" = writeSection(block, tag),
320 "\\if" =,
321 "\\ifelse" =
322 if (testRdConditional("text", block, Rdfile))
323 writeContent(block[[2L]], tag)
324 else if (tag == "\\ifelse")
325 writeContent(block[[3L]], tag),
326 "\\out" = for (i in seq_along(block))
327 put(block[[i]]),
328 stopRd(block, Rdfile, "Tag ", tag, " not recognized")
329 )
330 }
331
332 writeTabular <- function(table) { #!moin
333 formats <- table[[1L]]
334 if (length(formats) != 1L || RdTags(formats) != "TEXT")
335 stopRd(table, Rdfile, "\\tabular format must be simple text")
336 ftext <- formats[[1L]]
337 aligns <- strsplit(ftext, "", fixed = TRUE)[[1L]]
338 if (!all(aligns %in% fcodes))
339 stopRd(table, Rdfile, "Unrecognized \\tabular format: ", ftext)
340
341 content <- table[[2L]]
342 tags <- RdTags(content)
343 cells <- cell <- 1L
344 for (t in seq_along(tags)) {
345 cells[t] <- cell * (!tags[t] %in% c("\\tab", "\\cr"))
346 if (!cells[t]) cell <- t + 1L
347 }
348 if (tags[length(tags)] != "\\cr") cells[max(cells):length(tags)] <- 0
349
350 for (cell in unique(cells[cells])) {
351 save <- startCapture()
352 writeContent(content[cells == cell], tags[cell])
353 cells[cells == cell] <- 0
354 cells[cell] <- cell
355 content[cell] <- tidy(endCapture(save))
356 }
357
358 rows <- sum(as.integer(tags == "\\cr"))
359 cols <- sum(as.integer(tags %in% c("\\tab", "\\cr"))) / rows
360 if (cols != length(aligns))
361 stopRd(table, Rdfile,
362 "\\tabular formats (", ftext,
363 ") do not match columns found:", cols)
364 content <- unlist(content[cells])
365 cnt <<- content
366 table <- matrix(c(aligns, content), rows + 1, cols, byrow = TRUE)
367 tbl <<- table
368 blankLine()
369 put(markup(table, type = "table"))
370 }
371
372 writeCodeBlock <- function(blocks, blocktag) {
373 tags <- RdTags(blocks)
374 i <- 0
375 while (i < length(tags)) {
376 i <- i + 1
377 block <- blocks[[i]]
378 tag <- tags[i]
379 switch(tag,
380 "\\method" =,
381 "\\S3method" =,
382 "\\S4method" = {
383 blocks <- transformMethod(i, blocks, Rdfile)
384 tags <- RdTags(blocks)
385 i <- i - 1
386 },
387 UNKNOWN =,
388 VERB =,
389 RCODE =,
390 TEXT = writeCode(tabExpand(block)),
391 "\\donttest" =,
392 "\\special" =,
393 "\\var" = writeCodeBlock(block, tag),
394 "\\dots" =,
395 "\\ldots" = put(markup("...", "monospace")),
396 "\\dontrun" = writeDR(block, tag),
397 USERMACRO =,
398 "\\newcommand" =,
399 "\\renewcommand" =,
400 COMMENT =,
401 "\\dontshow" =,
402 "\\testonly" = {}, # do nothing
403 ## All the markup such as \emph
404 stopRd(block, Rdfile, "Tag ", tag, " not expected in code block")
405 )
406 }
407 }
408
409 writeContent <- function(blocks, blocktag) {
410 itemskip <- FALSE
411 tags <- RdTags(blocks)
412 for (i in seq_along(tags)) {
413 tag <- tags[i]
414 block <- blocks[[i]]
415 switch(tag,
416 "\\item" = {
417 switch(blocktag,
418 "\\describe" = {
419 blankLine()
420 save <- startCapture()
421 dropBlank <<- TRUE
422 writeContent(block[[1L]], tag)
423 DLlab <- endCapture(save)
424 put(" ", paste0(DLlab), " ") #!moin
425 writeContent(block[[2L]], tag)
426 blankLine(0L)
427 },
428 "\\value" =,
429 "\\arguments" = {
430 blankLine()
431 save <- startCapture()
432 dropBlank <<- TRUE
433 writeContent(block[[1L]], tag)
434 DLlab <- endCapture(save)
435 itemLabel <- setNames("", DLlab) #!moin
436 put(markup(itemLabel, "itemLabel")) #!moin
437 writeContent(block[[2L]], tag)
438 blankLine(0L)
439 },
440 "\\itemize" =,
441 "\\enumerate" = {
442 blankLine()
443 if (blocktag == "\\itemize") {
444 put(markup("", "itemBullet")) #!moin
445 } else {
446 enumItem <<- enumItem + 1L
447 put(markup("", "itemNumber", enumItem)) #!moin
448 }
449 })
450 itemskip <- TRUE
451 },
452 { # default
453 if (itemskip) {
454 ## The next item must be TEXT, and start with a space.
455 itemskip <- FALSE
456 if (tag == "TEXT") {
457 txt <- psub("^ ", "", as.character(tabExpand(block)))
458 put(txt) #!moin
459 } else {
460 writeBlock(block, tag, blocktag) # should not happen
461 }
462 } else {
463 writeBlock(block, tag, blocktag)
464 }
465 })
466 }
467 }
468
469 writeSection <- function(section, tag) {
470 if (tag %in% c("\\alias", "\\concept", "\\encoding", "\\keyword"))
471 return()
472 save <- c(sectionLevel, dropBlank)
473 blankLine() #!moin
474 sectionLevel <<- sectionLevel + 1L
475 if (tag == "\\section" || tag == "\\subsection") {
476 #!moin no markup allowed moin titles
477 title <- .Rd_format_title(section[[1L]]) #!moin
478 put(markup(title, "heading", sectionLevel)) #!moin
479 blankLine()
480 dropBlank <<- TRUE
481 writeContent(section[[2L]], tag)
482 } else if (tag %in% c("\\usage", "\\examples")) {#!moin
483 put(markup(sectionTitles[tag], "heading", sectionLevel))
484 blankLine()
485 dropBlank <<- TRUE
486 put(markup(type = ".codeBlockOpen"))
487 writeCodeBlock(section, tag)
488 put(markup(type = ".blockClose"))
489 } else {
490 put(markup(sectionTitles[tag], "heading", sectionLevel)) #!moin
491 blankLine()
492 dropBlank <<- TRUE
493 writeContent(section, tag)
494 }
495 blankLine()
496
497 sectionLevel <<- save[1L]
498 dropBlank <<- save[2L]
499 }
500
501 if (is.character(out)) {
502 if (out == "") {
503 con <- stdout()
504 } else {
505 con <- file(out, ifelse(append, "at", "wt")) #!moin
506 on.exit(close(con), add=TRUE)
507 }
508 } else {
509 con <- out
510 out <- summary(con)$description
511 }
512
513 if (!prepared) Rd <- prepare_Rd(Rd, defines=defines, stages=stages, fragment=fragment, ...)
514 Rdfile <- attr(Rd, "Rdfile")
515 sections <- RdTags(Rd)
516 if (fragment) {
517 if (sections[1L] %in% names(sectionOrder))
518 for (i in seq_along(sections))
519 writeSection(Rd[[i]], sections[i])
520 else
521 for (i in seq_along(sections))
522 writeBlock(Rd[[i]], sections[i], "")
523 } else {
524 title <- .Rd_format_title(.Rd_get_title(Rd))
525 name <- trim(Rd[[2L]][[1L]])
526 if (nzchar(package)) {
527 put(markup("", "hozline", 2)) #!moin
528 put('||<tablestyle="width: 100%" style="width: 50%; border: none;">', name, " {", package,
529 '} ||<style="width: 50%; text-align: right; border: none;">R Documentation` `||\n') #!moin
530 put(markup("", "hozline", 2)) #!moin
531 }
532 put(markup(name, "heading", sectionLevel)) #!moin
533 blankLine()
534 put(title)
535 blankLine()
536 for (i in seq_along(sections)[-(1:2)])
537 writeSection(Rd[[i]], sections[i])
538 }
539 blankLine(0L)
540 invisible(out)
541 }
You are not allowed to attach a file to this page.