SCM

SCM Repository

[inlinedocs] Annotation of /pkg/inlinedocs/R/parsers.R
ViewVC logotype

Annotation of /pkg/inlinedocs/R/parsers.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 395 - (view) (download)

1 : markus 394 #
2 :     # vim:set ff=unix expandtab ts=2 sw=2:
3 : tdhock 336 do.not.generate <- structure(function
4 : tdhock 335 ### Make a Parser Function used to indicate that certain Rd files
5 :     ### should not be generated.
6 :     (...
7 :     ### Character strings indicating Rd files without the .Rd suffix.
8 :     ){
9 :     filenames <- c(...)
10 :     function(docs,...){
11 :     for(fn in filenames){
12 :     docs[[fn]] <- list()
13 :     }
14 :     docs$.overwrite <- TRUE
15 :     docs
16 :     }
17 :     ### A Parser Function that will delete items from the outer
18 :     ### Documentation List.
19 : tdhock 336 },ex=function(){
20 :     silly.pkg <- system.file("silly",package="inlinedocs")
21 :     owd <- setwd(tempdir())
22 :     file.copy(silly.pkg,".",recursive=TRUE)
23 : tdhock 335
24 : tdhock 336 ## define a custom Parser Function that will not generate some Rd
25 :     ## files
26 :     custom <- do.not.generate("silly-package","Silly-class")
27 :     parsers <- c(default.parsers,list(exclude=custom))
28 :    
29 :     ## At first, no Rd files in the man subdirectory.
30 :     man.dir <- file.path("silly","man")
31 :     dir(man.dir)
32 :    
33 :     ## Running package.skeleton.dx will generate bare-bones files for
34 :     ## those specified in do.not.generate, if they do not exist.
35 :     package.skeleton.dx("silly",parsers)
36 :     Rd.files <- c("silly-package.Rd","Silly-class.Rd","silly.example.Rd")
37 :     Rd.paths <- file.path(man.dir,Rd.files)
38 :     stopifnot(all(file.exists(Rd.paths)))
39 :    
40 :     ## Save the modification times of the Rd files
41 :     old <- file.info(Rd.paths)$mtime
42 : tdhock 356
43 :     ## make sure there is at least 2 seconds elapsed, which is the
44 :     ## resolution for recording times on windows file systems.
45 :     Sys.sleep(4)
46 : tdhock 336
47 :     ## However, it will NOT generate Rd for files specified in
48 :     ## do.not.generate, if they DO exist already.
49 :     package.skeleton.dx("silly",parsers)
50 :     mtimes <- data.frame(old,new=file.info(Rd.paths)$mtime)
51 :     rownames(mtimes) <- Rd.files
52 :     mtimes$changed <- mtimes$old != mtimes$new
53 :     print(mtimes)
54 :     stopifnot(mtimes["silly-package.Rd","changed"]==FALSE)
55 :     stopifnot(mtimes["Silly-class.Rd","changed"]==FALSE)
56 :     stopifnot(mtimes["silly.example.Rd","changed"]==TRUE)
57 :    
58 :     unlink("silly",recursive=TRUE)
59 :     setwd(owd)
60 :     })
61 :    
62 : tdhock 376 ### combine NULL objects.
63 : markus 370 combine.NULL<-function(x,y){
64 :     if (class(x) == "NULL"){
65 :     # print(paste("mm x=",x))
66 :     # print(paste("mm class(x)=",class(x)))
67 :     x=list("")
68 :     }
69 :     if (class(y) == "NULL"){
70 :     # print(paste("mm y=",y))
71 :     # print(paste("mm class(y)=",class(y)))
72 :     y=list("")
73 :     }
74 :     return(combine(x,y))
75 :     }
76 : tdhock 376
77 :     ### combine lists or character strings
78 : markus 370 combine <- function(x,y){
79 :     UseMethod("combine")
80 :     }
81 : tdhock 110
82 :     ### combine character strings by pasting them together
83 :     combine.character <- function(x,y)
84 :     paste(x,y,sep="\n")
85 :    
86 :     ### combine lists by adding elements or adding to existing elements
87 :     combine.list <- function(x,y){
88 : tdhock 200 toadd <- if(".overwrite"%in%names(y)){
89 :     y <- y[names(y)!=".overwrite"]
90 :     rep(TRUE,length(y))
91 :     }else{
92 :     !names(y)%in%names(x)
93 :     }
94 : tdhock 185 toup <- names(y)[!toadd]
95 : tdhock 110 x[names(y)[toadd]] <- y[toadd]
96 :     for(up in toup)x[[up]] <- combine(x[[up]],y[[up]])
97 : tdhock 200 x
98 : tdhock 110 ### A list, same type as x, but with added elements from y.
99 :     }
100 :    
101 : tdhock 302
102 :     getSource <- function
103 :     ### Extract a function's source code.
104 :     (fun.obj
105 :     ### A function.
106 :     ) {
107 :     srcref <- attr(fun.obj, "srcref")
108 : tdhock 308 if (!is.null(srcref)) {
109 :     ##unlist(strsplit(as.character(srcref), "\n"))
110 :     as.character(srcref)
111 :     }
112 : tdhock 302 else attr(fun.obj, "source")
113 :     ### Source code lines as a character vector.
114 :     }
115 :    
116 : tdhock 110 ### Prefix for code comments used with grep and gsub.
117 : tdhock 257 prefix <- "^[ \t]*###[ \t]*"
118 : tdhock 110
119 :     decomment <- function
120 :     ### Remove comment prefix and join lines of code to form a
121 :     ### documentation string.
122 :     (comments
123 :     ### Character vector of prefixed comment lines.
124 :     ){
125 : tdhock 185 gsub(prefix,"",comments)
126 : tdhock 110 ### String without prefixes or newlines.
127 :     }
128 :    
129 : tdhock 162 forall <- function
130 : tdhock 158 ### For each object in the package that satisfies the criterion
131 :     ### checked by subfun, parse source using FUN and return the resulting
132 : tdhock 87 ### documentation list.
133 :     (FUN,
134 :     ### Function to apply to each element in the package.
135 :     subfun=function(x)TRUE
136 :     ### Function to select subsets of elements of the package, such as
137 :     ### is.function. subfun(x)==TRUE means FUN will be applied to x and
138 :     ### the result will be returned.
139 :     ){
140 : tdhock 138 FUN <- FUN
141 :     f <- function(objs,docs,...){
142 : tdhock 300 if(length(objs)==0)return(list())
143 : tdhock 87 objs <- objs[sapply(objs,subfun)]
144 :     L <- list()
145 : tdhock 162 on.exit(cat(sprintf("Parser Function failed on %s\n",N)))
146 : tdhock 204 for(N in union(names(docs),names(objs))){
147 : tdhock 87 o <- objs[[N]]
148 : tdhock 302 L[[N]] <- FUN(src=getSource(o),
149 : tdhock 89 name=N,objs=objs,o=o,docs=docs,doc=docs[[N]],...)
150 : tdhock 87 }
151 : tdhock 162 on.exit()## remove warning message
152 : tdhock 87 L
153 :     }
154 : tdhock 138 class(f) <- c("allfun","function")
155 :     f
156 : tdhock 87 ### A Parser Function.
157 :     }
158 :    
159 : tdhock 138 ### Print method for functions constructed using forall.
160 :     print.allfun <- function(x,...){
161 :     e <- environment(x)
162 :     cat("Function to apply to every element.\nselector:")
163 :     print(e$subfun)
164 :     cat("processor:")
165 :     print(e$FUN)
166 :     }
167 :    
168 : tdhock 87 ### For each function in the package, do something.
169 :     forfun <- function(FUN)forall(FUN,is.function)
170 :    
171 : markus 394 forGeneric<- function(
172 :     FUN ### Function to apply to each method in the package (usually FUN is a parser)
173 :     ,
174 :     env
175 :     ,
176 :     gens
177 :     ){
178 :     #pe(quote(getwd()),environment())
179 :     force(FUN)
180 :     f <- function(objs,docs,...){
181 :     genericFuncNames=names(gens)
182 :     L <- list()
183 :     for(genName in genericFuncNames){
184 :     fg=gens[[genName]]
185 :     meths=findMethods(fg,where=env)
186 :     signatureStrings=names(meths)
187 :     pp("signatureStrings",environment())
188 :     on.exit(cat(sprintf("Parser Function failed on %s\n",N)))
189 :     for ( sig in signatureStrings){
190 :     method <- meths[[sig]]
191 :     src=getSource(method)
192 :     N <- paste(genName,"-method-#",sig,sep="")
193 :     L[[N]] <- FUN(src=src,objs=meths,name=N,...)
194 :     }
195 :     on.exit()## remove warning message
196 :     }
197 :     L
198 :     }
199 :     f
200 :     }
201 :    
202 : tdhock 163 kill.prefix.whitespace <- function
203 :     ### Figure out what the whitespace preceding the example code is, and
204 :     ### then delete that from every line.
205 :     (ex
206 :     ### character vector of example code lines.
207 :     ){
208 :     tlines <- gsub("\\s*","",ex)
209 :     ##tlines <- gsub("#.*","",tlines)
210 :     prefixes <- unique(gsub("\\S.*","",ex[tlines!=""]))
211 :     FIND <- prefixes[which.min(nchar(prefixes))]
212 :     ## Eliminate leading tabulations or 2/4 spaces
213 :     sub(FIND, "", ex)
214 :     ### Character vector of code lines with preceding whitespace removed.
215 :     }
216 :    
217 : tdhock 175 prefixed.lines <- structure(function(src,...){
218 : tdhock 138 ### The primary mechanism of inline documentation is via consecutive
219 :     ### groups of lines matching the specified prefix regular expression
220 :     ### "\code{^### }" (i.e. lines beginning with "\code{### }") are
221 :     ### collected as follows into documentation sections:\describe{
222 :     ### \item{description}{group starting at line 2 in the code}
223 :     ### \item{arguments}{group following each function argument}
224 :     ### \item{value}{group ending at the penultimate line of the code}}
225 :     ### These may be added to by use of the \code{##<<} constructs
226 :     ### described below.
227 :     clines <- grep(prefix,src)
228 :     if(length(clines)==0)return(list())
229 :     bounds <- which(diff(clines)!=1)
230 :     starts <- c(1,bounds+1)
231 :     ends <- c(bounds,length(clines))
232 :     ## detect body of function using paren matching
233 : tdhock 159 code <- gsub("#.*","",src)
234 :     f <- function(ch)cumsum(nchar(gsub(sprintf("[^%s]",ch),"",code)))
235 : tdhock 138 parens <- f("(")-f(")")
236 :     body.begin <- which(diff(parens)<0 & parens[-1]==0)+2
237 : tdhock 175 if(length(body.begin)==0)body.begin <- 1 ## rare cases
238 : tdhock 138 is.arg <- function(){
239 : tdhock 159 gres <- grep("^\\s*#",src[start-1],perl=TRUE)
240 :     0 == length(gres) && start<=body.begin
241 :     }
242 : tdhock 138 res <- list()
243 :     for(i in seq_along(starts)){
244 :     start <- clines[starts[i]]
245 :     end <- clines[ends[i]]
246 : tdhock 304 processed <- gsub("#.*","",gsub("[ }]","",src[(end+1):length(src)]))
247 :     lab <- if(all(processed==""))"value"
248 : tdhock 138 else if(start==2)"description"
249 :     else if(is.arg()){
250 :     ##twutz: strip leading white spaces and brackets and ,
251 : kmpont 305 arg <- gsub("^[ \t(,]*", "", src[start - 1])
252 : tdhock 138 arg <- gsub("^([^=,]*)[=,].*", "\\1", arg)
253 :     ##twutz: remove trailing whitespaces
254 : kmpont 305 arg <- gsub("^([^ \t]*)([ \t]+)$","\\1",arg)
255 : tdhock 336 arg <- gsub("...", "\\dots", arg, fixed = TRUE)
256 : tdhock 138 paste("item{",arg,"}",sep="")
257 :     } else {
258 :     next;
259 :     }
260 :     res[[lab]] <- decomment(src[start:end])
261 :     }
262 :     res
263 : tdhock 175 },ex=function(){
264 :     test <- function
265 : tdhock 191 ### the description
266 : tdhock 175 (x,
267 :     ### the first argument
268 :     y ##<< another argument
269 :     ){
270 :     5
271 :     ### the return value
272 :     ##seealso<< foobar
273 : tdhock 138 }
274 : tdhock 302 src <- getSource(test)
275 : tdhock 175 prefixed.lines(src)
276 :     extract.xxx.chunks(src)
277 :     })
278 : tdhock 138
279 : tdhock 154 extract.xxx.chunks <- function # Extract documentation from a function
280 : tdhock 87 ### Given source code of a function, return a list describing inline
281 :     ### documentation in that source code.
282 : tdhock 154 (src,
283 :     ### The source lines of the function to examine, as a character
284 :     ### vector.
285 :     name.fun="(unnamed function)",
286 : tdhock 87 ### The name of the function/chunk to use in warning messages.
287 : tdhock 154 ...
288 :     ### ignored.
289 : tdhock 95 ){
290 : tdhock 87 res <- list()
291 :     ##details<< For simple functions/arguments, the argument may also be
292 :     ## documented by appending \code{##<<} comments on the same line as the
293 :     ## argument name. Mixing this mechanism with \code{###} comment lines for
294 :     ## the same argument is likely to lead to confusion, as the \code{###}
295 :     ## lines are processed first.
296 :     #arg.pat <- paste("^[^=,#]*?([\\w\\.]+)\\s*([=,].*|\\)\\s*)?",
297 :     # "<<\\s*(\\S.*?)\\s*$",
298 :     # sep="##") # paste avoids embedded trigger fooling the system
299 :     #tw: removed first comma
300 :     arg.pat <- paste("^[^=#]*?([\\w\\.]+)\\s*([=,].*|\\)\\s*)?",
301 :     "<<\\s*(\\S.*?)\\s*$",
302 :     sep="##") # paste avoids embedded trigger fooling the system
303 :    
304 :     skeleton.fields <- c("alias","details","keyword","references","author",
305 :     "note","seealso","value","title","description",
306 :     "describe","end")
307 :     ##details<< Additionally, consecutive sections of \code{##} comment
308 :     ## lines beginning with \code{##}\emph{xxx}\code{<<} (where
309 :     ## \emph{xxx} is one of the fields: \code{alias}, \code{details},
310 :     ## \code{keyword}, \code{references}, \code{author}, \code{note},
311 :     ## \code{seealso}, \code{value}, \code{title} or \code{description})
312 :     ## are accumulated and inserted in the relevant part of the .Rd
313 :     ## file.
314 :     ##
315 :     ## For \code{value}, \code{title}, \code{description} and function
316 :     ## arguments, these \emph{append} to any text from "prefix"
317 :     ## (\code{^### }) comment lines, irrespective of the order in the
318 :     ## source.
319 :     ##
320 :     ## When documenting S4 classes, documentation from \code{details}
321 :     ## sections will appear under a section \code{Objects from the Class}. That
322 :     ## section typically includes information about construction methods
323 :     ## as well as other description of class objects (but note that the
324 :     ## class Slots are documented in a separate section).
325 :    
326 :     ## but this should not appear, because separated by a blank line
327 :     extra.regexp <- paste("^\\s*##(",paste(skeleton.fields,collapse="|"),
328 :     ")<<\\s*(.*)$",sep="")
329 :     cont.re <- "^\\s*##\\s*"
330 :     in.describe <- 0
331 :     first.describe <- FALSE
332 :     k <- 1
333 :     in.chunk <- FALSE
334 :     end.chunk <- function(field,payload)
335 :     {
336 :     if ( "alias" == field ){
337 :     ##note<< \code{alias} extras are automatically split at new lines.
338 :     payload <- gsub("\\n+","\\}\n\\\\alias\\{",payload,perl=TRUE)
339 :     chunk.sep <- "}\n\\alias{"
340 :     } else if ( "keyword" == field ){
341 :     ##keyword<< documentation utilities
342 :     ##note<< \code{keyword} extras are automatically split at white space,
343 :     ## as all the valid keywords are single words.
344 :     payload <- gsub("\\s+","\\}\n\\\\keyword\\{",payload,perl=TRUE)
345 :     chunk.sep <- "}\n\\keyword{"
346 :     } else if ( "title" == field ){
347 :     chunk.sep <- " "
348 :     } else if ( "description" == field ){
349 :     chunk.sep <- "\n"
350 :     } else {
351 :     ##details<< Each separate extra section appears as a new
352 :     ## paragraph except that: \itemize{\item empty sections (no
353 :     ## matter how many lines) are ignored;\item \code{alias} and
354 :     ## \code{keyword} sections have special rules;\item
355 :     ## \code{description} should be brief, so all such sections
356 :     ## are concatenated as one paragraph;\item \code{title} should
357 :     ## be one line, so any extra \code{title} sections are
358 :     ## concatenated as a single line with spaces separating the
359 :     ## sections.}
360 :     chunk.sep <- "\n\n"
361 :     }
362 :     chunk.res <- NULL
363 : tdhock 191 if ( !grepl("^\\s*$",payload,perl=TRUE) )
364 : tdhock 87 chunk.res <-
365 :     if ( is.null(res[[field]]) ) payload
366 :     else paste(res[[field]], payload, sep=chunk.sep)
367 :     invisible(chunk.res)
368 :     }
369 : tdhock 154 while ( k <= length(src) ){
370 :     line <- src[k]
371 : tdhock 308 ##print(line)
372 :     ##if(grepl("^$",line))browser()
373 : tdhock 191 if ( grepl(extra.regexp,line,perl=TRUE) ){
374 : tdhock 87 ## we have a new extra chunk - first get field name and any payload
375 :     new.field <- gsub(extra.regexp,"\\1",line,perl=TRUE)
376 :     new.contents <- gsub(extra.regexp,"\\2",line,perl=TRUE)
377 : tdhock 308 ##cat(new.field,"\n-----\n",new.contents,"\n\n")
378 : tdhock 87 ##details<< As a special case, the construct \code{##describe<<} causes
379 :     ## similar processing to the main function arguments to be
380 :     ## applied in order to construct a describe block within the
381 :     ## documentation, for example to describe the members of a
382 :     ## list. All subsequent "same line" \code{##<<} comments go into that
383 :     ## block until terminated by a subsequent \code{##}\emph{xxx}\code{<<} line.
384 :     if ( "describe" == new.field ){
385 :     ##details<< Such regions may be nested, but not in such a way
386 : tdhock 307 ## that the first element in a \code{describe} is another
387 :     ## \code{describe}. Thus there must be at least one
388 :     ## \code{##<<} comment between each pair of
389 :     ## \code{##describe<<} comments.
390 : tdhock 87 if ( first.describe ){
391 :     stop("consecutive ##describe<< at line",k,"in",name.fun)
392 :     } else {
393 :     if ( nzchar(new.contents) ){
394 :     if ( is.null(payload) || 0 == nzchar(payload) ){
395 :     payload <- new.contents
396 :     } else {
397 :     payload <- paste(payload,new.contents,sep="\n\n")
398 :     }
399 :     }
400 :     first.describe <- TRUE
401 :     }
402 :     } else if ( "end" == new.field ){
403 :     ##details<< When nested \code{describe} blocks are used, a comment-only
404 :     ## line with \code{##end<<} terminates the current level only; any
405 :     ## other valid \code{##}\emph{xxx}\code{<<} line terminates
406 :     ## all open describe blocks.
407 :     if ( in.describe>0 ){
408 :     ## terminate current \item and \describe block only
409 :     if ( "value" == cur.field && 1 == in.describe ){
410 :     payload <- paste(payload,"}",sep="")
411 :     } else {
412 :     payload <- paste(payload,"}\n}",sep="")
413 :     }
414 :     in.describe <- in.describe-1;
415 :     } else {
416 :     warning("mismatched ##end<< at line ",k," in ",name.fun)
417 :     }
418 :     if ( nzchar(new.contents) ){
419 :     if ( nzchar(payload) ){
420 :     payload <- paste(payload,new.contents,sep="\n")
421 :     } else {
422 :     payload <- new.contents
423 :     }
424 :     }
425 :     } else {
426 :     ## terminate all open \describe blocks (+1 because of open item)
427 :     if ( 0 < in.describe ){
428 :     if ( "value" != cur.field ){ # value is implicit describe block
429 :     payload <- paste(payload,"}",sep="")
430 :     }
431 :     while ( in.describe>0 ){
432 :     payload <- paste(payload,"}",sep="\n")
433 :     in.describe <- in.describe-1;
434 :     }
435 :     }
436 :     ## finishing any existing payload
437 :     if ( in.chunk ) res[[cur.field]] <- end.chunk(cur.field,payload)
438 :     in.chunk <- TRUE
439 :     cur.field <- new.field
440 :     payload <- new.contents
441 :     ##note<< The "value" section of a .Rd file is implicitly a describe
442 :     ## block and \code{##}\code{value}\code{<<} acts accordingly. Therefore
443 :     ## it automatically enables the describe block itemization (##<< after
444 :     ## list entries).
445 :     if ( "value" == new.field ){
446 :     first.describe <- TRUE;
447 :     }
448 :     }
449 : tdhock 191 } else if ( in.chunk && grepl(cont.re,line,perl=TRUE) ){
450 : tdhock 87 ## append this line to current chunk
451 : tdhock 191 if ( !grepl(prefix,line,perl=TRUE) ){
452 : tdhock 87 ##describe<< Any lines with "\code{### }" at the left hand
453 :     ## margin within the included chunks are handled separately,
454 :     ## so if they appear in the documentation they will appear
455 :     ## before the \code{##}\emph{xxx}\code{<}\code{<} chunks.
456 :     ### This one should not appear.
457 :     stripped <- gsub(cont.re,"",line,perl=TRUE)
458 :     if ( nzchar(payload) ){
459 :     payload <- paste(payload,stripped,sep="\n")
460 :     } else {
461 :     payload <- stripped
462 :     }
463 :     }
464 : tdhock 191 } else if ( grepl(arg.pat,line,perl=TRUE) ){
465 : tdhock 87 not.describe <- (0==in.describe && !first.describe)
466 :     if ( in.chunk && not.describe){
467 :     res[[cur.field]] <- end.chunk(cur.field,payload)
468 :     }
469 :     comment <- gsub(arg.pat,"\\3",line,perl=TRUE);
470 :     arg <- gsub(arg.pat,"\\\\item\\{\\1\\}",line,perl=TRUE)
471 :     in.chunk <- TRUE
472 :     if ( not.describe ){
473 : tdhock 115 ## TDH 2010-06-18 For item{}s in the documentation list names,
474 :     ## we don't need to have a backslash before, so delete it.
475 :     arg <- gsub("^[\\]+","",arg)
476 : tdhock 336 cur.field <- gsub("...","\\dots",arg,fixed=TRUE) ##special case for dots
477 : tdhock 87 payload <- comment
478 :     } else {
479 :     ## this is a describe block, so we need to paste with existing
480 :     ## payload as a new \item.
481 :     if ( first.describe ){
482 :     ## for first item, need to add describe block starter
483 :     if ( "value" == cur.field ){
484 :     payload <- paste(payload,"\n",arg,"{",sep="")
485 :     } else {
486 :     payload <- paste(payload,"\\describe{\n",arg,"{",sep="")
487 :     }
488 :     first.describe <- FALSE
489 :     in.describe <- in.describe+1
490 :     } else {
491 :     ## subsequent item - terminate existing and start new
492 :     payload <- paste(payload,"}\n",arg,"{",sep="")
493 :     }
494 :     if ( nzchar(comment) ){
495 :     payload <- paste(payload,comment,sep="")
496 :     }
497 :     }
498 :     } else if ( in.chunk ){
499 :     if ( 0 == in.describe && !first.describe ){
500 :     ## reached an end to current field, but need to wait if in.describe
501 :     res[[cur.field]] <- end.chunk(cur.field,payload)
502 :     in.chunk <- FALSE
503 :     cur.field <- NULL
504 :     payload <- NULL
505 :     }
506 :     }
507 :     k <- k+1
508 :     }
509 :     ## finishing any existing payload
510 :     if ( 0 < in.describe ){
511 :     if ( "value" != cur.field ){ # value is implicit describe block
512 :     payload <- paste(payload,"}",sep="")
513 :     }
514 :     while ( in.describe>0 ){
515 :     payload <- paste(payload,"}",sep="\n")
516 :     in.describe <- in.describe-1;
517 :     }
518 :     }
519 :     if ( in.chunk ) res[[cur.field]] <- end.chunk(cur.field,payload)
520 :     res
521 :     ### Named list of character strings extracted from comments. For each
522 :     ### name N we will look for N\{...\} in the Rd file and replace it
523 :     ### with the string in this list (implemented in modify.Rd.file).
524 :     }
525 :    
526 : kmpont 212 leadingS3generic <- function # check whether function name is an S3 generic
527 :     ### Determines whether a function name looks like an S3 generic function
528 :     (name, ##<< name of function
529 :     env, ##<< environment to search for additional generics
530 :     ...) ##<< ignored here
531 :     {
532 :     ##details<< This function is one of the default parsers, but exposed as
533 :     ## possibly of more general interest. Given a function name of the form
534 :     ## x.y.z it looks for the generic function x applying to objects of class
535 :     ## y.z and also for generic function x.y applying to objects of class z.
536 :     ##
537 :     parts <- strsplit(name, ".", fixed = TRUE)[[1]]
538 :     l <- length(parts)
539 :     if (l > 1) {
540 :     for (i in 1:(l - 1)) {
541 :     ## Look for a generic function (known by the system or defined
542 :     ## in the package) that matches that part of the function name
543 :     generic <- paste(parts[1:i], collapse = ".")
544 : tdhock 389 if (any(generic %in% getKnownS3generics()) ||
545 :     findGeneric(generic, env) != "") {
546 : kmpont 305 object <- paste(parts[(i + 1):l], collapse = ".")
547 : kmpont 212 ##details<< Assumes that the first name which matches any known
548 :     ## generics is the target generic function, so if both x and x.y
549 :     ## are generic functions, will assume generic x applying to objects
550 :     ## of class y.z
551 :     ##value<< If a matching generic found returns a list with a single component:
552 :     return(list(.s3method=c(generic, object))) ##<< a character vector containing generic name and object name.
553 :     }
554 :     }
555 :     }
556 :     ##value<< If no matching generic functions are found, returns an empty list.
557 :     list()
558 :     }
559 :    
560 : markus 394 definition.from.source=function(doc,src,...){
561 :     def <- doc$definition
562 :     is.empty <- function(x)is.null(x)||x==""
563 :     if(is.empty(def) && !is.empty(src))
564 :     list(definition=src)
565 :     else list()
566 :     }
567 :     ## title from first line of function def
568 :     title.from.firstline=function(src,...){
569 :     first <- src[1]
570 :     if(!is.character(first))return(list())
571 :     if(!grepl("#",first))return(list())
572 :     list(title=gsub("[^#]*#\\s*(.*)","\\1",first,perl=TRUE))
573 :     }
574 :     ############
575 :     mm.examples.from.testfile=function(name,...){
576 :     pp("name",environment())
577 :     tsubdir <- getOption("inlinedocs.exampleDir")
578 :     trunk<- getOption("inlinedocs.exampleRegExpression")
579 :     if (is.null(tsubdir)) return(list())# do nothing
580 :     #pe(quote(getwd()),environment())
581 :     #pp("tsubdir",environment())
582 :     p <- paste(trunk,name,"\\.R$",sep="")
583 :     #pp("p",environment())
584 :     allfiles=dir(tsubdir)
585 :     #pp("allfiles",environment())
586 :     L<- allfiles[grepl(pattern=p,allfiles)]
587 :     #pp("L",environment())
588 :     path=function(l){file.path(tsubdir,l)}
589 :     paths=lapply(L,path)
590 :     print(lapply(paths,file.exists))
591 :    
592 :     if(length(L)>0){
593 :     exampleTexts= lapply(paths,readLines)
594 :     #pp("exampleTexts",environment())
595 :     combinedText <- unlist(exampleTexts)
596 :    
597 :     return(list(examples=combinedText))
598 :     #pp("combinedTexts",environment())
599 :     }
600 :     else{
601 :     list()
602 :     }
603 :     }
604 : tdhock 154 ### Parsers for each function that are constructed automatically. This
605 :     ### is a named list, and each element is a parser function for an
606 :     ### individual object.
607 :     forfun.parsers <-
608 :     list(prefixed.lines=prefixed.lines,
609 :     extract.xxx.chunks=extract.xxx.chunks,
610 : markus 394 title.from.firstline=title.from.firstline,
611 : tdhock 154 ## PhG: it is tests/FUN.R!!! I would like more flexibility here
612 :     ## please, let me choose which dir to use for examples!
613 :     ## Get examples for FUN from the file tests/FUN.R
614 :     examples.from.testfile=function(name,...){
615 :     tsubdir <- getOption("inlinedocs.exdir")
616 :     if (is.null(tsubdir)) tsubdir <- "tests" # Default value
617 :     tfile <- file.path("..",tsubdir,paste(name,".R",sep=""))
618 : markus 394 print(file.exists(tfile))
619 :     if(file.exists(tfile)){
620 : tdhock 185 list(examples=readLines(tfile))
621 : markus 394 }
622 : tdhock 154 else list()
623 :     },
624 : markus 394 mm.examples.from.testfile=mm.examples.from.testfile,
625 :     definition.from.source=definition.from.source
626 : tdhock 196 )
627 : tdhock 154
628 : markus 394 extract.docs<-function(parsed,objs,on){
629 :     #pp("on",environment())
630 :     extract.docs.try <-function(o,on)
631 : tdhock 154 {
632 :     ## Note: we could use parsed information here too, but that
633 : tomaschwut 393 ## would produce different results for R.methodsS3::setMethodS3 etc.
634 : tdhock 154 doc <- list()
635 :     if ( !is.null(parsed[[on]]) ){
636 :     if ( !is.na(parsed[[on]]@code[1]) ){ # no code given for generics
637 : tdhock 185 doc$definition <- paste(parsed[[on]]@code)
638 : tdhock 154 }
639 :     if(!"description"%in%names(doc) && !is.na(parsed[[on]]@description) ){
640 :     doc$description <- parsed[[on]]@description
641 :     }
642 : tomaschwut 393 ## if ( "R.methodsS3::setMethodS3" == parsed[[on]]@created ){
643 : kmpont 212 ## gen <- leadingS3generic(on,topenv())
644 :     ## if ( 0 < length(gen) ){
645 :     ## doc$.s3method <- gen$.s3method
646 :     ## cat("S3method(",gen$.s3method[1],",",gen$.s3method[2],")\n",sep="")
647 :     ## }
648 :     ## }
649 : tdhock 154 }
650 :     if("title" %in% names(doc) && !"description" %in% names(doc) ){
651 :     ## For short functions having both would duplicate, but a
652 :     ## description is required. Therefore automatically copy title
653 :     ## across to avoid errors at package build time.
654 :     doc$description <- doc$title
655 :     }
656 :     doc
657 :     }
658 :     res <- try({o <- objs[[on]]
659 :     extract.docs.try(o, on)},FALSE)
660 :     if(class(res)=="try-error"){
661 :     cat("Failed to extract docs for: ",on,"\n\n")
662 :     list()
663 :     } else if(0 == length(res) && inherits(objs[[on]],"standardGeneric")){
664 :     NULL
665 :     } else if(0 == length(res) && "function" %in% class(o)
666 : tdhock 302 && 1 == length(osource <- getSource(o))
667 : tdhock 191 && grepl(paste("UseMethod(",on,")",sep="\""),osource)
668 : tdhock 154 ){
669 :     ## phew - this should only pick up R.oo S3 generic definitions like:
670 :     ## attr(*, "source")= chr "function(...) UseMethod(\"select\")"
671 :     NULL
672 :     } else res
673 :     }
674 : markus 394
675 :     inherit.docs <- function(
676 :     parsed, ##<< a list of doc.link objects
677 :     res, ##<< the list of documentation to be extended
678 :     childName ##<< the name of the object who possibly inherits
679 :     ){
680 :     in.res <- res[[childName]] #start with the present
681 :     #pp("in.res",environment())
682 :     childsDocLink <-parsed[[childName]]
683 :     if ( !is.null(childsDocLink) ){
684 :     for ( parent in childsDocLink@parent ){
685 :     if ( !is.na(parent) ){
686 :     #pp("parent",environment())
687 :     #pe(quote(names(res)),environment())
688 :     #pe(quote(parent %in% names(res)),environment())
689 :     if ( is.null(in.res) ){
690 :     in.res <- res[[parent]]
691 :     } else if ( parent %in% names(res) ){
692 :     parent.docs <- res[[parent]]
693 :     for ( nn in names(parent.docs) ){
694 :     if ( !nn %in% names(in.res) ){
695 :     in.res[[nn]] <- parent.docs[[nn]]
696 :     }
697 :     }
698 :     }
699 :     }
700 :     }
701 :     }
702 :     invisible(in.res)
703 :     ### the possibly extended list of documentation
704 :     }
705 :     extra.class.docs <- function # Extract documentation from code chunks
706 :     ### Parse R code to extract inline documentation from comments around
707 :     ### each class
708 :     ### looking at the "source" attribute. This is a Parser Function that
709 :     ### can be used in the parser list of package.skeleton.dx(). TODO:
710 :     (code,
711 :     ### Code lines in a character vector containing multiple R objects to
712 :     ### parse for documentation.
713 :     objs,
714 :     ### The objects defined in the code.
715 :     env,
716 :     ### The environment they inhibit (needed to pass on)
717 :     ...
718 :     ### ignored
719 :     ){
720 : tdhock 154 doc.names <- names(objs)
721 : markus 394 parsed <- extract.file.parse(code,env)
722 :     res=list()
723 : tdhock 154 for ( nn in names(parsed) ){
724 :     if ( parsed[[nn]]@created == "setClass" ){
725 :     S4class.docs <- extract.docs.setClass(parsed[[nn]])
726 :     docname <- paste(nn,"class",sep="-")
727 :     if ( is.null(res[[docname]]) ){
728 :     res[[docname]] <- S4class.docs
729 :     doc.names <- c(doc.names,docname)
730 :     } else {
731 :     stop(nn," appears as both S4 class and some other definition")
732 :     }
733 :     }
734 :     }
735 : markus 394 all.done <- FALSE
736 :     while ( !all.done ){
737 :     res1 <- sapply(doc.names,inherit.docs,parsed=parsed,res=res,simplify=FALSE)
738 :     all.done <- identical(res1,res)
739 :     res <- res1
740 : tdhock 154 }
741 : markus 394 res
742 :     ### named list of lists, one for each object to document.
743 :     }
744 :     extra.code.docs <- function # Extract documentation from code chunks
745 :     ### Parse R code to extract inline documentation from comments around
746 :     ### each function. These are not able to be retreived simply by
747 :     ### looking at the "source" attribute. This is a Parser Function that
748 :     ### can be used in the parser list of package.skeleton.dx(). TODO:
749 :     ### Modularize this into separate Parsers Functions for S4 classes,
750 :     ### prefixes, ##<<blocks, etc. Right now it is not very clean!
751 :     (code,
752 :     ### Code lines in a character vector containing multiple R objects to
753 :     ### parse for documentation.
754 :     objs,
755 :     ### The objects defined in the code.
756 :     env, # the environment
757 :     ...
758 :     ### ignored
759 :     ){
760 :     parsed <- extract.file.parse(code,env)
761 :     doc.names <- names(objs)
762 :     res <- sapply(doc.names,extract.docs,parsed=parsed,objs=objs,simplify=FALSE)
763 : tdhock 154 all.done <- FALSE
764 :     while ( !all.done ){
765 : markus 394 res1 <- sapply(doc.names,inherit.docs,parsed=parsed,res=res,simplify=FALSE)
766 : tdhock 154 all.done <- identical(res1,res)
767 :     res <- res1
768 :     }
769 :     ## now strip out any generics (which have value NULL in res):
770 :     res.not.null <- sapply(res,function(x){!is.null(x)})
771 :     if ( 0 < length(res.not.null) && length(res.not.null) < length(res) ){
772 :     res <- res[res.not.null]
773 :     }
774 :     res
775 :     ### named list of lists, one for each object to document.
776 :     }
777 : markus 394 forMethod.parsers<-
778 :     list(
779 :     prefixed.lines=prefixed.lines,
780 :     extract.xxx.chunks=extract.xxx.chunks,
781 :     title.from.firstline=title.from.firstline,
782 :     mm.examples.from.testfile
783 :     )
784 :     ### List of Parser Functions that can be applied to any object.
785 :     forall.parsers <-
786 :     list(## Fill in author from DESCRIPTION and titles.
787 :     author.from.description=function(desc,...){
788 :     list(author=desc[,"Author"])
789 :     },
790 :     ## The format section sometimes causes problems, so erase it.
791 :     erase.format=function(...){
792 :     list(format="")
793 :     },
794 :     ## Convert the function name to a title.
795 :     title.from.name=function(name,doc,...){
796 :     if("title"%in%names(doc))list() else
797 :     list(title=gsub("[._]"," ",name))
798 :     },
799 :     ## PhG: here is what I propose for examples code in the 'ex' attribute
800 :     examples.in.attr = function (name, o, ...) {
801 : tdhock 395 ex <- attr(o, "ex", exact=TRUE)
802 : markus 394 if (!is.null(ex)) {
803 :     ## Special case for code contained in a function
804 :     if (inherits(ex, "function")) {
805 :     ## If source is available, start from there
806 :     src <- getSource(ex)
807 :     if (!is.null(src)) {
808 :     ex <- src
809 :     } else { ## Use the body of the function
810 :     ex <- deparse(body(ex))
811 :     }
812 :     ## Eliminate leading and trailing code
813 :     ex <- ex[-c(1, length(ex))]
814 :     if( length(ex) ){ # avoid error on yet empty example
815 :     if(ex[1]=="{")ex <- ex[-1]
816 :     ## all the prefixes
817 :     ex <- kill.prefix.whitespace(ex)
818 :     }
819 :     ## Add an empty line before and after example
820 :     ex <- c("", ex, "")
821 :     }
822 :     list(examples = ex)
823 :     } else list()
824 :     },collapse=function(doc,...){
825 :     L <- lapply(doc,paste,collapse="\n")
826 :     L$.overwrite <- TRUE
827 :     L
828 :     },tag.s3methods=leadingS3generic
829 :     )
830 : tdhock 154
831 : markus 394 ### List of parser functions that operate on single objects. This list
832 :     ### is useful for testing these functions.
833 :     lonely <- structure(c(forall.parsers,forfun.parsers),ex=function(){
834 :     f <- function # title
835 :     ### description
836 :     (x, ##<< arg x
837 :     y
838 :     ### arg y
839 :     ){
840 :     ##value<< a list with elements
841 :     list(x=x, ##<< original x value
842 :     y=y, ##<< original y value
843 :     sum=x+y) ##<< their sum
844 :     ##end<<
845 :     }
846 :     src <- getSource(f)
847 :     lonely$extract.xxx.chunks(src)
848 :     lonely$prefixed.lines(src)
849 :     })
850 :    
851 :    
852 : tdhock 154 ### List of parsers to use by default with package.skeleton.dx.
853 :     default.parsers <-
854 : markus 394 c(
855 :     extra.code.docs=extra.code.docs, ## TODO: cleanup!
856 :     extra.class.docs=extra.class.docs, ## TODO: cleanup!
857 : tdhock 154 sapply(forfun.parsers,forfun),
858 :     edit.package.file=function(desc,...){
859 :     in.details <- setdiff(colnames(desc),"Description")
860 : tdhock 185 details <- sprintf("%s: \\tab %s\\cr",in.details,desc[,in.details])
861 : tdhock 154 L <-
862 :     list(list(title=desc[,"Title"],
863 :     description=desc[,"Description"],
864 : tdhock 195 `tabular{ll}`=details))
865 : tdhock 154 names(L) <- paste(desc[,"Package"],"-package",sep="")
866 :     L
867 : tdhock 197 },
868 :     sapply(forall.parsers,forall)
869 : tdhock 186 )
870 : tdhock 154
871 : tdhock 87 setClass("DocLink", # Link documentation among related functions
872 :     ### The \code{.DocLink} class provides the basis for hooking together
873 :     ### documentation of related classes/functions/objects. The aim is that
874 : kmpont 212 ### documentation sections missing from the child are inherited from
875 :     ### the parent class.
876 : tdhock 87 representation(name="character", ##<< name of object
877 :     created="character", ##<< how created
878 :     parent="character", ##<< parent class or NA
879 :     code="character", ##<< actual source lines
880 :     description="character") ##<< preceding description block
881 :     )
882 :    
883 :     extract.file.parse <- function # File content analysis
884 : tdhock 356 ### Using the base \code{parse} function, analyse the file to link
885 : tdhock 87 ### preceding "prefix" comments to each active chunk. Those comments form
886 :     ### the default description for that chunk. The analysis also looks for
887 : markus 394 ### S4 class "setClass" ,R.oo setConstructorS3 R.methodsS3::setMethodS3
888 :     ### or S4 setMethod calls in order to link the documentation of those properly.
889 :     (code,
890 : tdhock 87 ### Lines of R source code in a character vector - note that any
891 :     ### nested \code{source} statements are \emph{ignored} when scanning
892 :     ### for class definitions.
893 : markus 394 env
894 :     ### the environment in which the code has been evaluated before.
895 :     ### This is e.g. iportant to make sure that we can evaluate expressions
896 :     ### like signature definitions for methods
897 : tdhock 87 ){
898 :     res <- list()
899 :     old.opt <- options(keep.source=TRUE)
900 :     parsed <- try(parse(text=code))
901 :     options(old.opt)
902 :     if ( inherits(parsed,"try-error") ){
903 :     stop("parse failed with error:\n",parsed)
904 :     }
905 :     chunks <- attr(parsed,"srcref")
906 :     last.end <- 0
907 :     for ( k in 1:length(parsed) ){
908 :     start <- chunks[[k]][1]
909 :     ##details<< If the definition chunk does not contain a
910 :     ## description, any immediately preceding sequence consecutive
911 :     ## "prefix" lines will be used instead.
912 :     default.description <- NULL
913 :     while ( start > last.end+1
914 : tdhock 191 && grepl(prefix,code[start-1],perl=TRUE) ){
915 : tdhock 87 start <- start-1
916 :     }
917 :     if ( start < chunks[[k]][1] ){
918 :     default.description <- decomment(code[start:(chunks[[k]][1]-1)])
919 :     } else {
920 :     default.description <- NA_character_;
921 :     }
922 :     ##details<< Class and method definitions can take several forms,
923 :     ## determined by expression type: \describe{
924 :     ## \item{assignment (<-)}{Ordinary assignment of value/function;}
925 :     ## \item{setClass}{Definition of S4 class;}
926 : markus 394 ## \item{setMethod}{Definition of a method of a S4 generic;}
927 : tdhock 87 ## \item{setConstructorS3}{Definition of S3 class using R.oo package;}
928 : tomaschwut 393 ## \item{R.methodsS3::setMethodS3}{Definition of method for S3 class using R.oo package.}}
929 : tdhock 87 ## Additionally, the value may be a name of a function defined elsewhere,
930 :     ## in which case the documentation should be copied from that other definition.
931 :     ## This is handled using the concept of documentation links.
932 :     lang <- parsed[[k]]
933 :     chars <- as.character(lang)
934 :     expr.type <- chars[1]
935 :     parent <- NA_character_
936 :    
937 : markus 394 if ( expr.type == "<-" || expr.type == "setConstructorS3" ){
938 : tdhock 87 object.name <- chars[2]
939 :     ## If the function definition is not embedded within the call, then
940 :     ## the parent is that function. Test whether the the third value
941 :     ## looks like a name and add it to parents if so.
942 : tdhock 191 if ( grepl("^[\\._\\w]+$",chars[3],perl=TRUE) ){
943 : tdhock 87 parent <- chars[3]
944 :     }
945 :     res[[object.name]] <- new("DocLink",name=object.name,
946 :     created=expr.type,
947 :     parent=parent,
948 :     code=paste(chunks[[k]],sep=""),
949 :     description=default.description)
950 : markus 394 } else if ( expr.type == "setClass" ){
951 :     object.name <- chars[2]
952 :     res[[object.name]] <- new("DocLink",name=object.name,
953 :     created=expr.type,
954 :     parent=parent,
955 :     code=paste(chunks[[k]],sep=""),
956 :     description=default.description)
957 :    
958 :     }
959 :     else if ( expr.type == "R.methodsS3::setMethodS3" || expr.type == "R.methodsS3::R.methodsS3::setMethodS3"){
960 : tomaschwut 393 ##details<< The \code{R.methodsS3::setMethodS3} calls introduce additional
961 : tdhock 87 ## complexity: they will define an additional S3 generic (which
962 :     ## needs documentation to avoid warnings at package build time)
963 :     ## unless one already exists. This also is handled by "linking"
964 : markus 394 ## documentation. A previously unseen S3generic is linked to the
965 :     ## first defining instances, subsequent definitions of that S3generic
966 : tdhock 87 ## also link back to the first defining instance.
967 : markus 394 S3generic.name <- chars[2]
968 :     object.name <- paste(S3generic.name,chars[3],sep=".")
969 :     if ( is.null(res[[S3generic.name]]) ){
970 :     ## TDH 9 April 2012 Do NOT add \\link in S3generic.desc below,
971 : tdhock 356 ## since it causes problems on R CMD check.
972 :     ##* checking Rd cross-references ... WARNING
973 :     ##Error in find.package(package, lib.loc) :
974 :     ## there is no package called ‘MASS’
975 :     ##Calls: <Anonymous> -> lapply -> FUN -> find.package
976 :    
977 : markus 394 S3generic.desc <-
978 : tdhock 356 paste("Generic method behind \\code{",object.name,"}",sep="")
979 : markus 394 res[[S3generic.name]] <- new("DocLink",
980 :     name=S3generic.name,
981 : tdhock 87 created=expr.type,
982 :     parent=object.name,
983 :     code=NA_character_,
984 : markus 394 description=S3generic.desc)
985 : tdhock 87 } else {
986 : markus 394 parent <- res[[S3generic.name]]@parent
987 : tdhock 87 }
988 :     ## If the function definition is not embedded within the call, then
989 :     ## the parent is that function. Test whether the the fourth value
990 :     ## looks like a name and add it to parents if so.
991 : tdhock 191 if ( grepl("^[\\._\\w]+$",chars[4],perl=TRUE) ){
992 : tdhock 87 parent <- c(chars[4],parent)
993 :     }
994 :     res[[object.name]] <- new("DocLink",name=object.name,
995 :     created=expr.type,
996 :     parent=parent,
997 :     code=paste(chunks[[k]],sep=""),
998 :     description=default.description)
999 : markus 394 } else if (expr.type == "setMethod" ) {
1000 :     pp("lang",environment())
1001 :     pp("chars",environment())
1002 :    
1003 :     ## Since we do not know if the arguments in the call to setMethod are given with
1004 :     ## keywords, partially matching keywords as an ordered list ore any
1005 :     ## combination of it, we use the same function as R (match.arg )
1006 :     ## to rewrite our argumentlist to a (pair)list from which
1007 :     ## we can extract the information easily
1008 :     KeyWords=c("f","signature","definition","where")
1009 :     NamedArgs=list() # the new argument list
1010 :     args=lang[2:length(lang)]
1011 :     argNames=names(args)
1012 :     pp("args",environment())
1013 :     pp("argNames",environment())
1014 :     for (i in seq_along(lang[2:length(lang)])){
1015 :     argName=argNames[[i]]
1016 :     if(argNames[[i]]==""){ # no keyword=value given for this arg
1017 :     NamedArgs[[KeyWords[[i]]]] <- args[[i]] #determining the keyword by position
1018 :     }else{
1019 :     newName=try(match.arg(argNames[[i]],KeyWords))
1020 :     if (class(newName)=="try-error") {
1021 :     stop(paste("could not match the argument with name : " ,argNames[[i]]," to a formal argument of setMethod",sep=""))
1022 :     }else{
1023 :     NamedArgs[[newName]] <- args[[i]]
1024 :     }
1025 :     }
1026 :     }
1027 :     pp("NamedArgs",environment())
1028 :     genName=NamedArgs[["f"]]
1029 :     sigexp=NamedArgs[["signature"]]
1030 :     pp("sigexp",environment())
1031 :     sig=eval(sigexp,env)
1032 :     pp("sig",environment())
1033 :     sigString <- paste(sig,collapse="#")
1034 :     N=paste(genName,"-method-#",sigString,sep="")
1035 :     object.name <- N
1036 :     pp("object.name",environment())
1037 :    
1038 :     ## If the function definition is not embedded within the call, then
1039 :     ## the parent is that function. Test whether the value for "definition"
1040 :     ## looks like a funktion name and add it to parents if so.
1041 :     def=paste(as.character(NamedArgs[["definition"]]),collapse="\n")
1042 :     if ( grepl("^[\\._\\w]+$",def,perl=TRUE) ){
1043 :     parent <- def
1044 :     }
1045 :     res[[object.name]] <- new("DocLink",name=object.name,
1046 :     created=expr.type,
1047 :     parent=parent,
1048 :     code=paste(chunks[[k]],sep=""),
1049 :     description=default.description)
1050 :     }else {
1051 :     ## Not sure what to do with these yet. Need to deal with setAs etc.
1052 : tdhock 87 }
1053 :     }
1054 :     invisible(res)
1055 :     ### Returns an invisible list of .DocLink objects.
1056 :     }
1057 :    
1058 :     extract.docs.setClass <- function # S4 class inline documentation
1059 :     ### Using the same conventions as for functions, definitions of S4 classes
1060 :     ### in the form \code{setClass("classname",\dots)} are also located and
1061 :     ### scanned for inline comments.
1062 : tdhock 93 (doc.link
1063 : tdhock 356 ### DocLink object as created by \code{extract.file.parse}.
1064 : tdhock 87 ### Note that \code{source} statements are \emph{ignored} when scanning for
1065 :     ### class definitions.
1066 : tdhock 93 ){
1067 : tdhock 87 chunk.source <- doc.link@code
1068 :     ##details<<
1069 :     ## Extraction of S4 class documentation is currently limited to expressions
1070 :     ## within the source code which have first line starting with
1071 :     ## \code{setClass("classname"}. These are located from the source file
1072 :     ## (allowing also for white space around the \code{setClass} and \code{(}).
1073 :     ## Note that \code{"classname"} must be a quoted character string;
1074 :     ## expressions returning such a string are not matched.
1075 :     class.name <- doc.link@name
1076 :    
1077 :     ##details<< For class definitions, the slots (elements of the
1078 :     ## \code{representation} list) fill the role of function
1079 :     ## arguments, so may be documented by \code{##<<} comments on
1080 :     ## the same line or \code{### } comments at the beginning of the
1081 :     ## following line.
1082 :     f.n <- paste(class.name,"class",sep="-")
1083 : tdhock 154 docs <- extract.xxx.chunks(chunk.source,f.n)
1084 : tdhock 138 ## also apply source parsing functions that I separated out into
1085 :     ## separate functions
1086 :     docs <- combine(docs,lonely$prefixed.lines(chunk.source))
1087 :     docs$title <- lonely$title.from.firstline(chunk.source)
1088 : tdhock 87 ##details<<
1089 : kmpont 305 ## If there is no explicit title on the first line of setClass, then
1090 :     ## one is made up from the class name.
1091 :     if ( 0 == length(docs$title) ){
1092 :     docs$title <- list(title=paste(class.name,"S4 class"))
1093 :     }
1094 :     ##details<<
1095 : tdhock 87 ## The class definition skeleton includes an \code{Objects from the Class}
1096 :     ## section, to which any \code{##details<<} documentation chunks are
1097 :     ## written. It is given a vanilla content if there are no specific
1098 :     ## \code{##details<<} documentation chunks.
1099 :     if ( is.null(docs[["details"]]) ){
1100 :     docs[["details"]] <-
1101 :     paste("Objects can be created by calls of the form \\code{new(",
1102 :     class.name," ...)}",sep="")
1103 :     }
1104 :     docs[["section{Objects from the Class}"]] <- docs[["details"]]
1105 :     ## seealso has a skeleton line not marked by ~ .. ~, so have to suppress
1106 :     if ( is.null(docs[["seealso"]]) ){
1107 :     docs[["seealso"]] <- ""
1108 :     }
1109 :     if ( is.null(docs[["alias"]]) ){
1110 :     docs[["alias"]] <- class.name
1111 :     }
1112 :     if ( is.null(docs[["description"]]) ){
1113 :     docs[["description"]] <- doc.link@description
1114 :     }
1115 :     invisible(docs)
1116 :     }
1117 : markus 394 createObjects <- function(code){
1118 :     # this is factored out to make writing tests easier
1119 :     # since we often need the objects and the environment
1120 :     # they inhabit
1121 : tdhock 105 e <- new.env()
1122 : kmpont 212 ## KMP 2011-03-09 fix problem with DocLink when inlinedocs ran on itself
1123 :     ## Error in assignClassDef(Class, classDef, where) :
1124 :     ## Class "DocLink" has a locked definition in package "inlinedocs"
1125 :     ## Traced to "where" argument in setClassDef which defaults to topenv()
1126 :     ## which in turn is inlinedocs when processing inlinedocs package, hence
1127 :     ## the clash. The following works (under R 2.12.2), so that the topenv()
1128 :     ## now finds e before finding the inlinedocs environment.
1129 : kmpont 213 old <- options(keep.source=TRUE,topLevelEnvironment=e)
1130 : tdhock 109 on.exit(options(old))
1131 : tdhock 110 exprs <- parse(text=code)
1132 : tdhock 248 ## TDH 2011-04-07 set this so that no warnings about creating a fake
1133 :     ## package when we try to process S4 classes defined in code
1134 :     e$.packageName <- "inlinedocs.processor"
1135 : tdhock 152 for (i in exprs){
1136 : tdhock 248 eval(i, e)
1137 : tdhock 152 }
1138 : markus 394 objs <- sapply(ls(e),get,e,simplify=FALSE) # note that ls will not find S4 classes nor methods for generic functions
1139 :     list(objs=objs,env=e,exprs=exprs)
1140 :     }
1141 : tdhock 105
1142 : markus 394
1143 :     apply.parsers<- function
1144 :     ### Parse code to r objs, then run all the parsers and return the
1145 :     ### documentation list.
1146 :     (code,
1147 :     ### Character vector of code lines.
1148 :     parsers=default.parsers,
1149 :     ### List of Parser Functions.
1150 :     verbose=FALSE,
1151 :     ### Echo names of Parser Functions?
1152 :     ...
1153 :     ### Additional arguments to pass to Parser Functions.
1154 :     ){
1155 :     # #####################################
1156 :     # e <- new.env()
1157 :     # ## KMP 2011-03-09 fix problem with DocLink when inlinedocs ran on itself
1158 :     # ## Error in assignClassDef(Class, classDef, where) :
1159 :     # ## Class "DocLink" has a locked definition in package "inlinedocs"
1160 :     # ## Traced to "where" argument in setClassDef which defaults to topenv()
1161 :     # ## which in turn is inlinedocs when processing inlinedocs package, hence
1162 :     # ## the clash. The following works (under R 2.12.2), so that the topenv()
1163 :     # ## now finds e before finding the inlinedocs environment.
1164 :     # old <- options(keep.source=TRUE,topLevelEnvironment=e)
1165 :     # on.exit(options(old))
1166 :     # exprs <- parse(text=code)
1167 :     # ## TDH 2011-04-07 set this so that no warnings about creating a fake
1168 :     # ## package when we try to process S4 classes defined in code
1169 :     # e$.packageName <- "inlinedocs.processor"
1170 :     # for (i in exprs){
1171 :     # eval(i, e)
1172 :     # }
1173 :     # objs <- sapply(ls(e),get,e,simplify=FALSE) # note that ls will not find S4 classes nor methods for generic functions
1174 :     l=createObjects(code)
1175 :     objs=l[["objs"]]
1176 :     e=l[["env"]]
1177 :     exprs=l[["exprs"]]
1178 :     # since th method definitions do not appear in ls() so are not represented in obs
1179 :     # so we have to find them in the parsed code
1180 :     glo=list()
1181 :     for ( k in 1:length(exprs)){
1182 :     lang <- exprs[[k]]
1183 :     chars <- as.character(lang)
1184 :     #pp("chars",environment())
1185 :     expr.type <- chars[[1]]
1186 :     object.name <- chars[[2]]
1187 :     if (expr.type == "setMethod"){glo=c(glo,object.name)}
1188 :     }
1189 :     gloFuncs=unlist(sapply(glo,getGeneric,where=e))
1190 :     #####################################
1191 : tdhock 105 docs <- list()
1192 : markus 394 # now find generic Functions that are defined in the code
1193 :     # since those lead to entries in objs we can find them
1194 :     pe(quote(length(names(objs))),environment())
1195 :     if (length(names(objs))!=0){
1196 :     definedGenerics=objs[sapply(names(objs),isGeneric,e)]
1197 :     }else{
1198 :     definedGenerics=list()
1199 :     }
1200 :     #gens=unique(c(definedGenerics,gloFuncs))
1201 :     gens=definedGenerics
1202 :     #gens=gloFuncs
1203 :     # gens=glo
1204 :     pp("gens",environment())
1205 :    
1206 : kmpont 305
1207 : tdhock 109 ## apply parsers in sequence to code and objs
1208 : tdhock 312 if(verbose)cat("Applying parsers:\n")
1209 : tdhock 105 for(i in seq_along(parsers)){
1210 :     N <- names(parsers[i])
1211 : markus 394 if(verbose){
1212 : tdhock 105 if(is.character(N) && N!=""){
1213 : markus 370 cat(" this is parser:",N,"\n",sep="")
1214 : tdhock 312 }else cat('.\n')
1215 : markus 394 }
1216 : tdhock 105 p <- parsers[[i]]
1217 :     ## This is the argument list that each parser receives:
1218 : tdhock 200 L <- p(code=code,objs=objs,docs=docs,env=e,...)
1219 : markus 394 docs <- combine(docs,L)
1220 : tdhock 105 }
1221 : tdhock 196 ## post-process to collapse all character vectors
1222 :     for(i in seq_along(docs)){
1223 :     for(j in seq_along(docs[[i]])){
1224 : tdhock 198 if(names(docs[[i]])[j]!=".s3method")
1225 : tdhock 196 docs[[i]][[j]] <- paste(docs[[i]][[j]],collapse="\n")
1226 :     }
1227 : markus 324 }
1228 : tdhock 105 if(verbose)cat("\n")
1229 : markus 394 ## mm I added a second parser loop here for my method parsers
1230 :     ## It would perhaps be possible to integrate the new parsers in the
1231 :     ## main loop above
1232 :     docs2 <- list()
1233 :     parsersForMethods=sapply(forMethod.parsers,forGeneric,env=e,gens=gens)
1234 :     for(i in seq_along(parsersForMethods)){
1235 :     N <- names(parsersForMethods[[i]])
1236 :     p <- parsersForMethods[[i]]
1237 :     cat(" this is parser:",N,"\n",sep="")
1238 :     L <- p(code=code,objs=objs,docs=docs2,env=e,...)
1239 :     #pp("L",environment())
1240 :     docs2 <- combine(docs2,L)
1241 :     }
1242 :    
1243 :     return(list(docs=combine(docs,docs2),env=e,objs=objs,gens=gens))
1244 : tdhock 105 ### A list of extracted documentation from code.
1245 :     }
1246 : tdhock 109
1247 : tdhock 138 ### Names of Parser Functions that operate on the desc arg.
1248 :     descfile.names <- c("author.from.description","edit.package.file")
1249 :    
1250 :     ### Names of Parser Functions that do NOT use the desc arg.
1251 :     non.descfile.names <-
1252 :     names(default.parsers)[!names(default.parsers)%in%descfile.names]
1253 :    
1254 : tdhock 118 ### Parsers that operate only on R code, independently of the
1255 :     ### description file.
1256 : tdhock 138 nondesc.parsers <- default.parsers[non.descfile.names]
1257 : tdhock 118
1258 : tdhock 209 extract.docs.file <- structure(function
1259 : tdhock 109 ### Apply all parsers relevant to extract info from just 1 code file.
1260 :     (f,
1261 :     ### File name of R code to read and parse.
1262 : tdhock 203 parsers=NULL,
1263 : tdhock 109 ### Parser Functions to use to parse the code and extract
1264 :     ### documentation.
1265 :     ...
1266 :     ### Other arguments to pass to Parser Functions.
1267 :     ){
1268 : tdhock 203 if(is.null(parsers))parsers <- nondesc.parsers
1269 : markus 394 apply.parsers(readLines(f),parsers,verbose=FALSE,...)[["docs"]]
1270 : tdhock 209 },ex=function(){
1271 :     f <- system.file("silly","R","silly.R",package="inlinedocs")
1272 : tdhock 248 extract.docs.file(f)
1273 : tdhock 209 })
1274 : tdhock 248

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge