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 400 - (view) (download)

1 : markus 394 #
2 : markus 396 ############################################################
3 :     sigString <- function(sig){paste(sig,collapse="_")}
4 :     ############################################################
5 :     methodDocName=function
6 :     ### creates the actual *.Rd filename for a method from its signature and the generic it implements
7 :     (genName,sig){
8 :     N=paste(genName,"_method__",sigString(sig),sep="")
9 :     N
10 :     }
11 : markus 394 # vim:set ff=unix expandtab ts=2 sw=2:
12 : markus 396 ############################################################
13 :     setMethod("[",
14 :     signature(x = "listOfMethods", i = "logical"),
15 :     function
16 :     ### overload the [] operator for objects of class "listOfMethods"
17 :     (x, i, j, ..., drop = TRUE)
18 :     {
19 :     fdef <- x@generic
20 :     object <- new("listOfMethods", arguments = fdef@signature)
21 :     object@generic <- fdef
22 :     object@signatures <- x@signatures[i]
23 :     object@.Data <- x@.Data[i]
24 :     object@names <- x@names[i]
25 :     #pe(quote(class(object)),environment())
26 :     object
27 :    
28 :     }
29 :     )
30 :     ############################################################
31 :     mmPromptMethods <- function (genName, filename = NULL, exportedMeths,where)
32 :     ## this is a copy of R s own promptMehtods functions but
33 :     ## with an additional argument of the methods to be exported (and documented)
34 :     {
35 :    
36 :     genExported <- !is.null(exportedMeths)
37 :    
38 :     escape <- function(txt) gsub("%", "\\\\%", txt)
39 :     packageString <- ""
40 :     fdef <- getGeneric(genName,where=where)
41 :     if (!isGeneric(f=genName ,where=where,fdef = fdef))
42 :     stop(gettextf("no generic function found corresponding to %s",
43 :     sQuote(genName)), domain = NA)
44 :     methods <- findMethods(fdef,where=where)
45 :    
46 :     #where <- .genEnv(fdef, topenv(parent.frame()))
47 :     #if (!identical(where, .GlobalEnv))
48 :     # packageString <- sprintf("in Package \\pkg{%s}",
49 :     # getPackageName(where))
50 :     fullName <- utils:::topicName("methods", genName)
51 :    
52 :     n <- length(methods)
53 :     labels <- character(n)
54 :     aliases <- character(n)
55 :     signatures <- findMethodSignatures(methods = methods, target = TRUE)
56 :     args <- colnames(signatures)
57 :     for (i in seq_len(n)) {
58 :     sigi <- signatures[i, ]
59 :     labels[[i]] <- sprintf("\\code{signature(%s)}", paste(sprintf("%s = \"%s\"",
60 :     args, escape(sigi)), collapse = ", "))
61 :     aliases[[i]] <- paste0("\\alias{", utils:::topicName("method",
62 :     c(genName, signatures[i, ])), "}")
63 :     }
64 :     ####
65 :     if(genExported){
66 :     exportedSignatures <-findMethodSignatures(methods =exportedMeths, target = TRUE)
67 :     # #pp("exportedSignatures",environment())
68 :     n=nrow(exportedSignatures)
69 :     labels <- character(n)
70 :     items<- character(n)
71 :     args <- colnames(exportedSignatures)
72 :     for (i in seq_len(n)) {
73 :     sigi <- exportedSignatures[i, ]
74 :     N <- methodDocName(genName,sigi)
75 :     labels[[i]] <- sprintf("\\code{signature(%s)}", paste(sprintf("%s = \"%s\"",
76 :     args, escape(sigi)), collapse = ", "))
77 :     items[[i]]<- paste0(" \\item{", labels[[i]], "}{\n \\code{\\link{",N,"}} \n }")
78 :    
79 :     }
80 :     des <- paste0(
81 :     "\\description{\n ~~ Methods for function",
82 :     " \\code{", genName, "}",
83 :     sub("^in Package", "in package", packageString),
84 :     " ~~\n}"
85 :     )
86 :    
87 :     text <- c("\\section{Methods}{\n \\describe{", items, "\n }\n}")
88 :    
89 :     }else{
90 :     des <- paste0(
91 :     "\\description{\n All methods for function",
92 :     " \\code{", genName, "} ",
93 :     "are intended for internal use inside the package only. \n}"
94 :     )
95 :     #item<-'
96 :     #All methods for this generic are privat. (not exported into the namespace).
97 :     #To discourage use outside the package the documentation is truncated.
98 :     #'
99 :     #text <- c("\\section{Methods}{\n\\describe{", item, "}\n}")
100 :     text <- "" #no method section at all
101 :     }
102 :     aliasText <- c(paste0("\\alias{", escape(fullName), "}"),
103 :     escape(aliases))
104 :     if (identical(filename, FALSE))
105 :     return(c(aliasText, text))
106 :     if (is.null(filename) || identical(filename, TRUE))
107 :     filename <- paste0(fullName, ".Rd")
108 :     Rdtxt <- list(name = paste0("\\name{", fullName, "}"), type = "\\docType{methods}",
109 :     aliases = aliasText, title = sprintf("\\title{ ~~ Methods for Function \\code{%s} %s ~~}",
110 :     genName, packageString), description = des
111 :     , `section{Methods}` = text,
112 :     keywords = c("\\keyword{methods}", "\\keyword{ ~~ other possible keyword(s) ~~ }"))
113 :     if (is.na(filename))
114 :     return(Rdtxt)
115 :     cat(unlist(Rdtxt), file = filename, sep = "\n")
116 :     print(paste("A shell of methods documentation has been written",filename))
117 :     invisible(filename)
118 :     }
119 :    
120 :     ############################################################
121 :     removeComma <- function(str){
122 :     if(grepl(",",str)){
123 :     str <- strsplit(str,",")[[1]][[1]]
124 :     }
125 :     return(str)
126 :     }
127 :     ############################################################
128 :     exported=function
129 :     ### a helper soon to read the NAMESPACE file, soon to be replaced by Rs own function
130 :     (pattern,tD){
131 :     ##pp("tD",environment())
132 :     #pe(quote(getwd()),environment())
133 :     # for simpler parsing we dont allow every possible
134 :     # export statement but assume the form
135 :     # export(
136 :     # firstFunc,
137 :     # secondFunc
138 :     # )
139 :     ns=readLines(file.path(tD,"NAMESPACE"))
140 :     if(any(grepl(pattern,ns))){
141 :     fl=grep(pattern,ns)[[1]]
142 :     # start search for closing ")" at the opening one and
143 :     # use only the next ")" if there are several
144 :     ll= grep("\\)",ns[fl:length(ns)])[[1]]+fl-1
145 :     if (ll==fl+1){
146 :     return(NULL)
147 :     }else{
148 :     trunks= unlist(lapply(ns[(fl+1):(ll-1)],removeComma))
149 :     return(trunks)
150 :     }
151 :     }else{
152 :     return(NULL)
153 :     }
154 :     }
155 :     ############################################################
156 :     exportedFunctions=function
157 :     ### get the exported functions from the NAMESPACE file
158 :     (tD){
159 :     funcNames=exported("export\\(",tD)
160 :     #pp("funcNames",environment())
161 :     return(funcNames)
162 :     }
163 :     ############################################################
164 :     exportedGenerics=function
165 :     ### get the exported generic functions from the NAMESPACE file
166 :     (tD){
167 :     # note that there is only a exportMethods statement available
168 :     funcNames=exported("exportMethods",tD)
169 :     return(funcNames)
170 :     }
171 :     ############################################################
172 :     exportedClasses=function
173 :     ### get the exported Classes from the NAMESPACE file
174 :     (tD){
175 :     classnames=exported("exportClasses",tD)
176 :     return(classnames)
177 :     }
178 :     ############################################################
179 :     methodTable <- function(exprs,e){
180 :     gens=list() ## a list of generic functions that are mentioned in setMethod statements within the code to be documented
181 :     for ( k in 1:length(exprs)){
182 :     lang <- exprs[[k]]
183 :     chars <- as.character(lang)
184 :     ##pp("chars",environment())
185 :     expr.type <- chars[[1]]
186 :     if (expr.type == "setMethod"){
187 :     NamedArgs=rewriteSetMethodArgs(lang)
188 :     nameOfGeneric<-NamedArgs[["f"]]
189 :     methSig <- eval(NamedArgs[["signature"]],e)
190 :     gens[[nameOfGeneric]] <- unique(c(gens[[nameOfGeneric]],list(methSig)))
191 :     }
192 :     }
193 :     gens
194 :     }
195 :     ############################################################
196 :     allClasses <- function(env){
197 :     getClasses(where=env)
198 :     }
199 :     ############################################################
200 :     hiddenClasses <- function(env,pkgDir){
201 :     setdiff(allClasses(env),exportedClasses(pkgDir))
202 :     }
203 :     ############################################################
204 :     # now find all Generics whose src can be found
205 :     GenHasSrc=function
206 :     ### This function tells us if we can find a src reference for this generic
207 :     (genName,e)
208 :     {!is.null(getSrcref(getGeneric(genName,where=e)))}
209 :    
210 :    
211 :     # we now want to find all Generics that have at least one Method where we can get at the source
212 :     ############################################################
213 :     methSrc=function
214 :     ### get at the src of a method given as an MethodDefinition object
215 :     (MethodDefinition){getSrcref(unRematchDefinition(MethodDefinition))}
216 :     ############################################################
217 :     methSig=function
218 :     ### Extract the definition as text from an MethodDefinition object
219 :     (MethodDefinition){attr(MethodDefinition,"defined")}
220 :     ############################################################
221 :     MethodHasSrc=function(MethodDefinition)
222 :     ### This function tells if we can find a src reference for this method
223 :     {!is.null(methSrc(MethodDefinition))}
224 :     ############################################################
225 :     MethodSignatureHasOnlyExportedClasses=function(MethodDefinition,env,pkgDir)
226 :     ### check if all the classes in the signature are exported in the NAMESPACE file.
227 :     ### This information is needed to decide which Methods we want to document in cases
228 :     ### where the documentations is restricted to the exported NAMESPACE
229 :     {
230 :     sigStr=as.character(methSig(MethodDefinition))
231 :     hiddCls <- hiddenClasses(env,pkgDir)
232 :     intersection <- intersect(sigStr,hiddCls)
233 :     res <- (length(intersection)==0)
234 :     res
235 :     }
236 :     ############################################################
237 :     MethodsWithSrcRefForGen=function
238 :     ### Not all methods for a Generic are defined in the src we want to document.
239 :     ### This function helps to find the methods we want.
240 :     (genName,env){
241 :     l=findMethods(genName,where=env)[sapply(findMethods(genName,where=env),MethodHasSrc)]
242 :     #class(l)<-"methods"
243 :     l
244 :     }
245 :     ############################################################
246 :     GenHasAnyMethodWithSrc=function
247 :     ### function to check if we have a src reference for any of the methods of this generic
248 :     ### This helps to decide how the *-methods.Rd file should look like for this generic
249 :     (genName,env){
250 :     methDefs <- findMethods(genName,where=env)
251 :     ##pp("methDefs)
252 :     any(sapply(
253 :     methDefs,
254 :     MethodHasSrc))
255 :     }
256 :     ############################################################
257 :     GenHasAnyExposedMethod=function
258 :     ### function used to check if a GenericFunction has any method where the whole signature consist of classes exported in the namespace
259 :     (genName,env,pkgDir){
260 :     decide=function(MethodDescription){
261 :     MethodSignatureHasOnlyExportedClasses(MethodDescription,env,pkgDir)
262 :     }
263 :     hasExposedMethod <- any(
264 :     sapply(
265 :     findMethods(genName,where=env)
266 :     ,decide
267 :     )
268 :     )
269 :     #pp("genName",environment())
270 :     #pp("hasExposedMethod",environment())
271 :     hasExposedMethod
272 :     }
273 :     ############################################################
274 :     documentableMeths<- function(e){
275 :     # now find out which generics have any documentable methods
276 :     allGens=as.character(getGenerics(where=e))
277 :     ##pp("allGens",environment())
278 :     decide=function(genName){
279 :     GenHasAnyMethodWithSrc(genName,e)
280 :     }
281 :     GensWithDocMethods=allGens[unlist(sapply(allGens,decide))]
282 :     ##pp("GensWithDocMethods",environment())
283 :     # now we can make a list of list
284 :     # containing the Methods we want to documents ordered after the name of there Generics
285 :     documentableMeths=list()
286 :     for (genName in GensWithDocMethods){
287 :     documentableMeths[[genName]]<-MethodsWithSrcRefForGen(genName,e)
288 :     }
289 :     documentableMeths
290 :     }
291 :     ############################################################
292 :     exportedDocumentableMeths<- function(e,pkgDir){
293 :     decide1=function(genName){
294 :     GenHasAnyExposedMethod(genName,e,pkgDir)
295 :     }
296 :     dm <- documentableMeths(e)
297 :     indices=unlist(sapply(names(dm),decide1))
298 :     #pp("indices",environment())
299 :     newGens <- dm[indices]
300 :     decide2 <- function(MethodDescription){
301 :     MethodSignatureHasOnlyExportedClasses(MethodDescription,e,pkgDir)
302 :     }
303 :     for (genName in names(newGens)){
304 :     allMeths=newGens[[genName]]
305 :     newGens[[genName]] <- allMeths[sapply(allMeths,decide2)]
306 :     }
307 :     newGens
308 :    
309 :     }
310 :     ############################################################
311 :     getMethodName <- function(doc.link,e){
312 :     method.name<- doc.link@name
313 :     method.name
314 :     }
315 :     ############################################################
316 :     getMethodSrc <- function(doc.link,e){
317 :     chunk.source <- doc.link@code
318 :     method.name<- doc.link@name
319 :     old.opt <- options(keep.source=TRUE)
320 :     parsed <- try(parse(text=chunk.source))
321 :     options(old.opt)
322 :     if ( inherits(parsed,"try-error") ){
323 :     stop("parse failed with error:\n",parsed)
324 :     }
325 :     lp <- length(parsed)
326 :     ##pp("lp",environment())
327 :     ##pp("parsed",environment())
328 :     if(lp!=1){
329 :     stop("extract.docs.setMethod:the expected code should be a lingle setMethod expression")
330 :     }
331 :    
332 :    
333 :     NamedArgs=rewriteSetMethodArgs(parsed[[1]])
334 :     #pp("NamedArgs",environment())
335 :     s <- NamedArgs[["signature"]]
336 :     #pp("s",environment())
337 :     methodDef=getMethod(
338 :     f=NamedArgs[["f"]],
339 :     signature=eval(NamedArgs[["signature"]]),
340 :     where=e
341 :     )
342 :     #pp("methodDef",environment())
343 :     src=as.character(getSrcref(unRematchDefinition(methodDef)))
344 :     src
345 :     }
346 :     rewriteSetMethodArgs=function(lang){
347 :     ### Since we do not know if the arguments in the call to setMethod are given with
348 :     ### keywords, partially matching keywords as an ordered list or any
349 :     ### combination of it, we use the same function as R (match.arg )
350 :     ### to rewrite our argumentlist to a (pair)list from which
351 :     ### we can extract the information easily
352 :     KeyWords=c("f","signature","definition","where")
353 :     NamedArgs=list() # the new argument list
354 :     args=lang[2:length(lang)]
355 :     argNames=names(args)
356 :     if(is.null(argNames)){
357 :     # in the special case keyword=value pairs are not given at all
358 :     # we determine them by position
359 :     for (i in seq_along(args)){
360 :     #pp("i",environment())
361 :     NamedArgs[[KeyWords[[i]] ]] <- args[[i]]
362 :     }
363 :     }else{
364 :     # at least some keyword=value pairs are given
365 :     # we determine them by match arg or by position
366 :     for (i in seq_along(args)){
367 :     argName=argNames[[i]]
368 :     if(argNames[[i]]==""){ # no keyword=value given for this arg
369 :     NamedArgs[[KeyWords[[i]]]] <- args[[i]] #determining the keyword by position
370 :     }else{
371 :     newName=try(match.arg(argNames[[i]],KeyWords))
372 :     if (class(newName)=="try-error") {
373 :     stop(paste("could not match the argument with name : " ,argNames[[i]]," to a formal argument of setMethod",sep=""))
374 :     }else{
375 :     NamedArgs[[newName]] <- args[[i]]
376 :     }
377 :     }
378 :     }
379 :     }
380 :     #NN <- names(NamedArgs)
381 :     ##pp("lang",environment())
382 :     ##pp("args",environment())
383 :     ##pp("argNames",environment())
384 :     ##pp("NN",environment())
385 :     NamedArgs
386 :     }
387 : tdhock 336 do.not.generate <- structure(function
388 : tdhock 335 ### Make a Parser Function used to indicate that certain Rd files
389 :     ### should not be generated.
390 :     (...
391 :     ### Character strings indicating Rd files without the .Rd suffix.
392 :     ){
393 :     filenames <- c(...)
394 :     function(docs,...){
395 :     for(fn in filenames){
396 :     docs[[fn]] <- list()
397 :     }
398 :     docs$.overwrite <- TRUE
399 :     docs
400 :     }
401 :     ### A Parser Function that will delete items from the outer
402 :     ### Documentation List.
403 : tdhock 336 },ex=function(){
404 :     silly.pkg <- system.file("silly",package="inlinedocs")
405 :     owd <- setwd(tempdir())
406 :     file.copy(silly.pkg,".",recursive=TRUE)
407 : tdhock 335
408 : tdhock 336 ## define a custom Parser Function that will not generate some Rd
409 :     ## files
410 :     custom <- do.not.generate("silly-package","Silly-class")
411 :     parsers <- c(default.parsers,list(exclude=custom))
412 :    
413 :     ## At first, no Rd files in the man subdirectory.
414 :     man.dir <- file.path("silly","man")
415 :     dir(man.dir)
416 :    
417 :     ## Running package.skeleton.dx will generate bare-bones files for
418 :     ## those specified in do.not.generate, if they do not exist.
419 :     package.skeleton.dx("silly",parsers)
420 :     Rd.files <- c("silly-package.Rd","Silly-class.Rd","silly.example.Rd")
421 :     Rd.paths <- file.path(man.dir,Rd.files)
422 :     stopifnot(all(file.exists(Rd.paths)))
423 :    
424 :     ## Save the modification times of the Rd files
425 :     old <- file.info(Rd.paths)$mtime
426 : tdhock 356
427 :     ## make sure there is at least 2 seconds elapsed, which is the
428 :     ## resolution for recording times on windows file systems.
429 :     Sys.sleep(4)
430 : tdhock 336
431 :     ## However, it will NOT generate Rd for files specified in
432 :     ## do.not.generate, if they DO exist already.
433 :     package.skeleton.dx("silly",parsers)
434 :     mtimes <- data.frame(old,new=file.info(Rd.paths)$mtime)
435 :     rownames(mtimes) <- Rd.files
436 :     mtimes$changed <- mtimes$old != mtimes$new
437 :     print(mtimes)
438 :     stopifnot(mtimes["silly-package.Rd","changed"]==FALSE)
439 :     stopifnot(mtimes["Silly-class.Rd","changed"]==FALSE)
440 :     stopifnot(mtimes["silly.example.Rd","changed"]==TRUE)
441 :    
442 :     unlink("silly",recursive=TRUE)
443 :     setwd(owd)
444 :     })
445 :    
446 : tdhock 376 ### combine NULL objects.
447 : markus 370 combine.NULL<-function(x,y){
448 : markus 396 if ((class(x) == "NULL")& (class(y) == "NULL")){
449 :     # print(paste("mm x=",x))
450 :     # print(paste("mm class(x)=",class(x)))
451 :     return(NULL)
452 :     }
453 : markus 370 if (class(x) == "NULL"){
454 :     # print(paste("mm x=",x))
455 :     # print(paste("mm class(x)=",class(x)))
456 :     x=list("")
457 :     }
458 :     if (class(y) == "NULL"){
459 :     # print(paste("mm y=",y))
460 :     # print(paste("mm class(y)=",class(y)))
461 :     y=list("")
462 :     }
463 :     return(combine(x,y))
464 :     }
465 : tdhock 376
466 :     ### combine lists or character strings
467 : markus 370 combine <- function(x,y){
468 :     UseMethod("combine")
469 :     }
470 : tdhock 110
471 :     ### combine character strings by pasting them together
472 :     combine.character <- function(x,y)
473 :     paste(x,y,sep="\n")
474 :    
475 :     ### combine lists by adding elements or adding to existing elements
476 :     combine.list <- function(x,y){
477 : tdhock 200 toadd <- if(".overwrite"%in%names(y)){
478 :     y <- y[names(y)!=".overwrite"]
479 :     rep(TRUE,length(y))
480 :     }else{
481 :     !names(y)%in%names(x)
482 :     }
483 : tdhock 185 toup <- names(y)[!toadd]
484 : tdhock 110 x[names(y)[toadd]] <- y[toadd]
485 :     for(up in toup)x[[up]] <- combine(x[[up]],y[[up]])
486 : tdhock 200 x
487 : tdhock 110 ### A list, same type as x, but with added elements from y.
488 :     }
489 :    
490 : tdhock 302
491 :     getSource <- function
492 :     ### Extract a function's source code.
493 :     (fun.obj
494 :     ### A function.
495 :     ) {
496 :     srcref <- attr(fun.obj, "srcref")
497 : tdhock 308 if (!is.null(srcref)) {
498 :     ##unlist(strsplit(as.character(srcref), "\n"))
499 :     as.character(srcref)
500 :     }
501 : tdhock 302 else attr(fun.obj, "source")
502 :     ### Source code lines as a character vector.
503 :     }
504 :    
505 : tdhock 110 ### Prefix for code comments used with grep and gsub.
506 : tdhock 257 prefix <- "^[ \t]*###[ \t]*"
507 : tdhock 110
508 :     decomment <- function
509 :     ### Remove comment prefix and join lines of code to form a
510 :     ### documentation string.
511 :     (comments
512 :     ### Character vector of prefixed comment lines.
513 :     ){
514 : tdhock 185 gsub(prefix,"",comments)
515 : tdhock 110 ### String without prefixes or newlines.
516 :     }
517 :    
518 : tdhock 162 forall <- function
519 : tdhock 158 ### For each object in the package that satisfies the criterion
520 :     ### checked by subfun, parse source using FUN and return the resulting
521 : tdhock 87 ### documentation list.
522 :     (FUN,
523 :     ### Function to apply to each element in the package.
524 :     subfun=function(x)TRUE
525 :     ### Function to select subsets of elements of the package, such as
526 :     ### is.function. subfun(x)==TRUE means FUN will be applied to x and
527 :     ### the result will be returned.
528 :     ){
529 : tdhock 138 FUN <- FUN
530 :     f <- function(objs,docs,...){
531 : tdhock 300 if(length(objs)==0)return(list())
532 : tdhock 87 objs <- objs[sapply(objs,subfun)]
533 :     L <- list()
534 : tdhock 162 on.exit(cat(sprintf("Parser Function failed on %s\n",N)))
535 : tdhock 204 for(N in union(names(docs),names(objs))){
536 : tdhock 87 o <- objs[[N]]
537 : tdhock 302 L[[N]] <- FUN(src=getSource(o),
538 : tdhock 89 name=N,objs=objs,o=o,docs=docs,doc=docs[[N]],...)
539 : tdhock 87 }
540 : tdhock 162 on.exit()## remove warning message
541 : tdhock 87 L
542 :     }
543 : tdhock 138 class(f) <- c("allfun","function")
544 :     f
545 : tdhock 87 ### A Parser Function.
546 :     }
547 :    
548 : tdhock 138 ### Print method for functions constructed using forall.
549 :     print.allfun <- function(x,...){
550 :     e <- environment(x)
551 :     cat("Function to apply to every element.\nselector:")
552 :     print(e$subfun)
553 :     cat("processor:")
554 :     print(e$FUN)
555 :     }
556 :    
557 : tdhock 87 ### For each function in the package, do something.
558 : markus 396 forfun<- function
559 :     ### For each object in the package that satisfies the criterion
560 :     ### checked by subfun, parse source using FUN and return the resulting
561 :     ### documentation list.
562 :     (FUN
563 :     ### Function to apply to each function in the package.
564 :     ){
565 :     FUN <- FUN
566 :     f <- function(objs,docs,...){
567 :     if(length(objs)==0)return(list())
568 :     objs <- objs[sapply(objs,is.function)]
569 :     L <- list()
570 :     on.exit(cat(sprintf("Parser Function failed on %s\n",N)))
571 :     for(N in names(objs)){
572 :     o <- objs[[N]]
573 :     L[[N]] <- FUN(src=getSource(o),
574 :     name=N,objs=objs,o=o,docs=docs,doc=docs[[N]],...)
575 : markus 394 }
576 : markus 396 on.exit()## remove warning message
577 : markus 394 L
578 :     }
579 : markus 396 class(f) <- c("allfun","function")
580 : markus 394 f
581 : markus 396 ### A Parser Function.
582 : markus 394 }
583 :    
584 : tdhock 163 kill.prefix.whitespace <- function
585 :     ### Figure out what the whitespace preceding the example code is, and
586 :     ### then delete that from every line.
587 :     (ex
588 :     ### character vector of example code lines.
589 :     ){
590 :     tlines <- gsub("\\s*","",ex)
591 :     ##tlines <- gsub("#.*","",tlines)
592 :     prefixes <- unique(gsub("\\S.*","",ex[tlines!=""]))
593 :     FIND <- prefixes[which.min(nchar(prefixes))]
594 :     ## Eliminate leading tabulations or 2/4 spaces
595 :     sub(FIND, "", ex)
596 :     ### Character vector of code lines with preceding whitespace removed.
597 :     }
598 :    
599 : tdhock 175 prefixed.lines <- structure(function(src,...){
600 : tdhock 138 ### The primary mechanism of inline documentation is via consecutive
601 :     ### groups of lines matching the specified prefix regular expression
602 :     ### "\code{^### }" (i.e. lines beginning with "\code{### }") are
603 :     ### collected as follows into documentation sections:\describe{
604 :     ### \item{description}{group starting at line 2 in the code}
605 :     ### \item{arguments}{group following each function argument}
606 :     ### \item{value}{group ending at the penultimate line of the code}}
607 :     ### These may be added to by use of the \code{##<<} constructs
608 :     ### described below.
609 :     clines <- grep(prefix,src)
610 :     if(length(clines)==0)return(list())
611 :     bounds <- which(diff(clines)!=1)
612 :     starts <- c(1,bounds+1)
613 :     ends <- c(bounds,length(clines))
614 :     ## detect body of function using paren matching
615 : tdhock 159 code <- gsub("#.*","",src)
616 :     f <- function(ch)cumsum(nchar(gsub(sprintf("[^%s]",ch),"",code)))
617 : tdhock 138 parens <- f("(")-f(")")
618 :     body.begin <- which(diff(parens)<0 & parens[-1]==0)+2
619 : tdhock 175 if(length(body.begin)==0)body.begin <- 1 ## rare cases
620 : tdhock 138 is.arg <- function(){
621 : tdhock 159 gres <- grep("^\\s*#",src[start-1],perl=TRUE)
622 :     0 == length(gres) && start<=body.begin
623 :     }
624 : tdhock 138 res <- list()
625 :     for(i in seq_along(starts)){
626 :     start <- clines[starts[i]]
627 :     end <- clines[ends[i]]
628 : tdhock 304 processed <- gsub("#.*","",gsub("[ }]","",src[(end+1):length(src)]))
629 :     lab <- if(all(processed==""))"value"
630 : tdhock 138 else if(start==2)"description"
631 :     else if(is.arg()){
632 :     ##twutz: strip leading white spaces and brackets and ,
633 : kmpont 305 arg <- gsub("^[ \t(,]*", "", src[start - 1])
634 : tdhock 138 arg <- gsub("^([^=,]*)[=,].*", "\\1", arg)
635 :     ##twutz: remove trailing whitespaces
636 : kmpont 305 arg <- gsub("^([^ \t]*)([ \t]+)$","\\1",arg)
637 : tdhock 336 arg <- gsub("...", "\\dots", arg, fixed = TRUE)
638 : tdhock 138 paste("item{",arg,"}",sep="")
639 :     } else {
640 :     next;
641 :     }
642 :     res[[lab]] <- decomment(src[start:end])
643 :     }
644 :     res
645 : tdhock 175 },ex=function(){
646 :     test <- function
647 : tdhock 191 ### the description
648 : tdhock 175 (x,
649 :     ### the first argument
650 :     y ##<< another argument
651 :     ){
652 :     5
653 :     ### the return value
654 :     ##seealso<< foobar
655 : tdhock 138 }
656 : tdhock 302 src <- getSource(test)
657 : tdhock 175 prefixed.lines(src)
658 :     extract.xxx.chunks(src)
659 :     })
660 : tdhock 138
661 : tdhock 154 extract.xxx.chunks <- function # Extract documentation from a function
662 : tdhock 87 ### Given source code of a function, return a list describing inline
663 :     ### documentation in that source code.
664 : tdhock 154 (src,
665 :     ### The source lines of the function to examine, as a character
666 :     ### vector.
667 :     name.fun="(unnamed function)",
668 : tdhock 87 ### The name of the function/chunk to use in warning messages.
669 : tdhock 154 ...
670 :     ### ignored.
671 : tdhock 95 ){
672 : tdhock 87 res <- list()
673 :     ##details<< For simple functions/arguments, the argument may also be
674 :     ## documented by appending \code{##<<} comments on the same line as the
675 :     ## argument name. Mixing this mechanism with \code{###} comment lines for
676 :     ## the same argument is likely to lead to confusion, as the \code{###}
677 :     ## lines are processed first.
678 :     #arg.pat <- paste("^[^=,#]*?([\\w\\.]+)\\s*([=,].*|\\)\\s*)?",
679 :     # "<<\\s*(\\S.*?)\\s*$",
680 :     # sep="##") # paste avoids embedded trigger fooling the system
681 :     #tw: removed first comma
682 :     arg.pat <- paste("^[^=#]*?([\\w\\.]+)\\s*([=,].*|\\)\\s*)?",
683 :     "<<\\s*(\\S.*?)\\s*$",
684 :     sep="##") # paste avoids embedded trigger fooling the system
685 :    
686 :     skeleton.fields <- c("alias","details","keyword","references","author",
687 :     "note","seealso","value","title","description",
688 :     "describe","end")
689 :     ##details<< Additionally, consecutive sections of \code{##} comment
690 :     ## lines beginning with \code{##}\emph{xxx}\code{<<} (where
691 :     ## \emph{xxx} is one of the fields: \code{alias}, \code{details},
692 :     ## \code{keyword}, \code{references}, \code{author}, \code{note},
693 :     ## \code{seealso}, \code{value}, \code{title} or \code{description})
694 :     ## are accumulated and inserted in the relevant part of the .Rd
695 :     ## file.
696 :     ##
697 :     ## For \code{value}, \code{title}, \code{description} and function
698 :     ## arguments, these \emph{append} to any text from "prefix"
699 :     ## (\code{^### }) comment lines, irrespective of the order in the
700 :     ## source.
701 :     ##
702 :     ## When documenting S4 classes, documentation from \code{details}
703 :     ## sections will appear under a section \code{Objects from the Class}. That
704 :     ## section typically includes information about construction methods
705 :     ## as well as other description of class objects (but note that the
706 :     ## class Slots are documented in a separate section).
707 :    
708 :     ## but this should not appear, because separated by a blank line
709 :     extra.regexp <- paste("^\\s*##(",paste(skeleton.fields,collapse="|"),
710 :     ")<<\\s*(.*)$",sep="")
711 :     cont.re <- "^\\s*##\\s*"
712 :     in.describe <- 0
713 :     first.describe <- FALSE
714 :     k <- 1
715 :     in.chunk <- FALSE
716 :     end.chunk <- function(field,payload)
717 :     {
718 :     if ( "alias" == field ){
719 :     ##note<< \code{alias} extras are automatically split at new lines.
720 :     payload <- gsub("\\n+","\\}\n\\\\alias\\{",payload,perl=TRUE)
721 :     chunk.sep <- "}\n\\alias{"
722 :     } else if ( "keyword" == field ){
723 :     ##keyword<< documentation utilities
724 :     ##note<< \code{keyword} extras are automatically split at white space,
725 :     ## as all the valid keywords are single words.
726 :     payload <- gsub("\\s+","\\}\n\\\\keyword\\{",payload,perl=TRUE)
727 :     chunk.sep <- "}\n\\keyword{"
728 :     } else if ( "title" == field ){
729 :     chunk.sep <- " "
730 :     } else if ( "description" == field ){
731 :     chunk.sep <- "\n"
732 :     } else {
733 :     ##details<< Each separate extra section appears as a new
734 :     ## paragraph except that: \itemize{\item empty sections (no
735 :     ## matter how many lines) are ignored;\item \code{alias} and
736 :     ## \code{keyword} sections have special rules;\item
737 :     ## \code{description} should be brief, so all such sections
738 :     ## are concatenated as one paragraph;\item \code{title} should
739 :     ## be one line, so any extra \code{title} sections are
740 :     ## concatenated as a single line with spaces separating the
741 :     ## sections.}
742 :     chunk.sep <- "\n\n"
743 :     }
744 :     chunk.res <- NULL
745 : tdhock 191 if ( !grepl("^\\s*$",payload,perl=TRUE) )
746 : tdhock 87 chunk.res <-
747 :     if ( is.null(res[[field]]) ) payload
748 :     else paste(res[[field]], payload, sep=chunk.sep)
749 :     invisible(chunk.res)
750 :     }
751 : tdhock 154 while ( k <= length(src) ){
752 :     line <- src[k]
753 : tdhock 308 ##print(line)
754 :     ##if(grepl("^$",line))browser()
755 : tdhock 191 if ( grepl(extra.regexp,line,perl=TRUE) ){
756 : tdhock 87 ## we have a new extra chunk - first get field name and any payload
757 :     new.field <- gsub(extra.regexp,"\\1",line,perl=TRUE)
758 :     new.contents <- gsub(extra.regexp,"\\2",line,perl=TRUE)
759 : tdhock 308 ##cat(new.field,"\n-----\n",new.contents,"\n\n")
760 : tdhock 87 ##details<< As a special case, the construct \code{##describe<<} causes
761 :     ## similar processing to the main function arguments to be
762 :     ## applied in order to construct a describe block within the
763 :     ## documentation, for example to describe the members of a
764 :     ## list. All subsequent "same line" \code{##<<} comments go into that
765 :     ## block until terminated by a subsequent \code{##}\emph{xxx}\code{<<} line.
766 :     if ( "describe" == new.field ){
767 :     ##details<< Such regions may be nested, but not in such a way
768 : tdhock 307 ## that the first element in a \code{describe} is another
769 :     ## \code{describe}. Thus there must be at least one
770 :     ## \code{##<<} comment between each pair of
771 :     ## \code{##describe<<} comments.
772 : tdhock 87 if ( first.describe ){
773 :     stop("consecutive ##describe<< at line",k,"in",name.fun)
774 :     } else {
775 :     if ( nzchar(new.contents) ){
776 :     if ( is.null(payload) || 0 == nzchar(payload) ){
777 :     payload <- new.contents
778 :     } else {
779 :     payload <- paste(payload,new.contents,sep="\n\n")
780 :     }
781 :     }
782 :     first.describe <- TRUE
783 :     }
784 :     } else if ( "end" == new.field ){
785 :     ##details<< When nested \code{describe} blocks are used, a comment-only
786 :     ## line with \code{##end<<} terminates the current level only; any
787 :     ## other valid \code{##}\emph{xxx}\code{<<} line terminates
788 :     ## all open describe blocks.
789 :     if ( in.describe>0 ){
790 :     ## terminate current \item and \describe block only
791 :     if ( "value" == cur.field && 1 == in.describe ){
792 :     payload <- paste(payload,"}",sep="")
793 :     } else {
794 :     payload <- paste(payload,"}\n}",sep="")
795 :     }
796 :     in.describe <- in.describe-1;
797 :     } else {
798 :     warning("mismatched ##end<< at line ",k," in ",name.fun)
799 :     }
800 :     if ( nzchar(new.contents) ){
801 :     if ( nzchar(payload) ){
802 :     payload <- paste(payload,new.contents,sep="\n")
803 :     } else {
804 :     payload <- new.contents
805 :     }
806 :     }
807 :     } else {
808 :     ## terminate all open \describe blocks (+1 because of open item)
809 :     if ( 0 < in.describe ){
810 :     if ( "value" != cur.field ){ # value is implicit describe block
811 :     payload <- paste(payload,"}",sep="")
812 :     }
813 :     while ( in.describe>0 ){
814 :     payload <- paste(payload,"}",sep="\n")
815 :     in.describe <- in.describe-1;
816 :     }
817 :     }
818 :     ## finishing any existing payload
819 :     if ( in.chunk ) res[[cur.field]] <- end.chunk(cur.field,payload)
820 :     in.chunk <- TRUE
821 :     cur.field <- new.field
822 :     payload <- new.contents
823 :     ##note<< The "value" section of a .Rd file is implicitly a describe
824 :     ## block and \code{##}\code{value}\code{<<} acts accordingly. Therefore
825 :     ## it automatically enables the describe block itemization (##<< after
826 :     ## list entries).
827 :     if ( "value" == new.field ){
828 :     first.describe <- TRUE;
829 :     }
830 :     }
831 : tdhock 191 } else if ( in.chunk && grepl(cont.re,line,perl=TRUE) ){
832 : tdhock 87 ## append this line to current chunk
833 : tdhock 191 if ( !grepl(prefix,line,perl=TRUE) ){
834 : tdhock 87 ##describe<< Any lines with "\code{### }" at the left hand
835 :     ## margin within the included chunks are handled separately,
836 :     ## so if they appear in the documentation they will appear
837 :     ## before the \code{##}\emph{xxx}\code{<}\code{<} chunks.
838 :     ### This one should not appear.
839 :     stripped <- gsub(cont.re,"",line,perl=TRUE)
840 :     if ( nzchar(payload) ){
841 :     payload <- paste(payload,stripped,sep="\n")
842 :     } else {
843 :     payload <- stripped
844 :     }
845 :     }
846 : tdhock 191 } else if ( grepl(arg.pat,line,perl=TRUE) ){
847 : tdhock 87 not.describe <- (0==in.describe && !first.describe)
848 :     if ( in.chunk && not.describe){
849 :     res[[cur.field]] <- end.chunk(cur.field,payload)
850 :     }
851 :     comment <- gsub(arg.pat,"\\3",line,perl=TRUE);
852 :     arg <- gsub(arg.pat,"\\\\item\\{\\1\\}",line,perl=TRUE)
853 :     in.chunk <- TRUE
854 :     if ( not.describe ){
855 : tdhock 115 ## TDH 2010-06-18 For item{}s in the documentation list names,
856 :     ## we don't need to have a backslash before, so delete it.
857 :     arg <- gsub("^[\\]+","",arg)
858 : tdhock 336 cur.field <- gsub("...","\\dots",arg,fixed=TRUE) ##special case for dots
859 : tdhock 87 payload <- comment
860 :     } else {
861 :     ## this is a describe block, so we need to paste with existing
862 :     ## payload as a new \item.
863 :     if ( first.describe ){
864 :     ## for first item, need to add describe block starter
865 :     if ( "value" == cur.field ){
866 :     payload <- paste(payload,"\n",arg,"{",sep="")
867 :     } else {
868 :     payload <- paste(payload,"\\describe{\n",arg,"{",sep="")
869 :     }
870 :     first.describe <- FALSE
871 :     in.describe <- in.describe+1
872 :     } else {
873 :     ## subsequent item - terminate existing and start new
874 :     payload <- paste(payload,"}\n",arg,"{",sep="")
875 :     }
876 :     if ( nzchar(comment) ){
877 :     payload <- paste(payload,comment,sep="")
878 :     }
879 :     }
880 :     } else if ( in.chunk ){
881 :     if ( 0 == in.describe && !first.describe ){
882 :     ## reached an end to current field, but need to wait if in.describe
883 :     res[[cur.field]] <- end.chunk(cur.field,payload)
884 :     in.chunk <- FALSE
885 :     cur.field <- NULL
886 :     payload <- NULL
887 :     }
888 :     }
889 :     k <- k+1
890 :     }
891 :     ## finishing any existing payload
892 :     if ( 0 < in.describe ){
893 :     if ( "value" != cur.field ){ # value is implicit describe block
894 :     payload <- paste(payload,"}",sep="")
895 :     }
896 :     while ( in.describe>0 ){
897 :     payload <- paste(payload,"}",sep="\n")
898 :     in.describe <- in.describe-1;
899 :     }
900 :     }
901 :     if ( in.chunk ) res[[cur.field]] <- end.chunk(cur.field,payload)
902 :     res
903 :     ### Named list of character strings extracted from comments. For each
904 :     ### name N we will look for N\{...\} in the Rd file and replace it
905 :     ### with the string in this list (implemented in modify.Rd.file).
906 :     }
907 :    
908 : kmpont 212 leadingS3generic <- function # check whether function name is an S3 generic
909 :     ### Determines whether a function name looks like an S3 generic function
910 :     (name, ##<< name of function
911 :     env, ##<< environment to search for additional generics
912 :     ...) ##<< ignored here
913 :     {
914 :     ##details<< This function is one of the default parsers, but exposed as
915 :     ## possibly of more general interest. Given a function name of the form
916 :     ## x.y.z it looks for the generic function x applying to objects of class
917 :     ## y.z and also for generic function x.y applying to objects of class z.
918 :     ##
919 :     parts <- strsplit(name, ".", fixed = TRUE)[[1]]
920 :     l <- length(parts)
921 : tomaschwut 400 # twutz 29 April 2015: added nzchar to handle non-S3 functions such as .myPrivateMethod
922 :     if (nzchar(parts[1]) && l > 1) {
923 : kmpont 212 for (i in 1:(l - 1)) {
924 :     ## Look for a generic function (known by the system or defined
925 :     ## in the package) that matches that part of the function name
926 :     generic <- paste(parts[1:i], collapse = ".")
927 : tdhock 389 if (any(generic %in% getKnownS3generics()) ||
928 :     findGeneric(generic, env) != "") {
929 : kmpont 305 object <- paste(parts[(i + 1):l], collapse = ".")
930 : kmpont 212 ##details<< Assumes that the first name which matches any known
931 :     ## generics is the target generic function, so if both x and x.y
932 :     ## are generic functions, will assume generic x applying to objects
933 :     ## of class y.z
934 :     ##value<< If a matching generic found returns a list with a single component:
935 :     return(list(.s3method=c(generic, object))) ##<< a character vector containing generic name and object name.
936 :     }
937 :     }
938 :     }
939 :     ##value<< If no matching generic functions are found, returns an empty list.
940 :     list()
941 :     }
942 :    
943 : markus 396 definition.from.source=function(doc,src,...)
944 :     ### small helper to extract the definition of a doc entry from a bit of src code
945 :     {
946 : markus 394 def <- doc$definition
947 :     is.empty <- function(x)is.null(x)||x==""
948 :     if(is.empty(def) && !is.empty(src))
949 :     list(definition=src)
950 :     else list()
951 :     }
952 :     ## title from first line of function def
953 : markus 396 title.from.firstline=function
954 :     ### extract the title from the first line of a function definition
955 :     (src,...){
956 : markus 394 first <- src[1]
957 :     if(!is.character(first))return(list())
958 :     if(!grepl("#",first))return(list())
959 :     list(title=gsub("[^#]*#\\s*(.*)","\\1",first,perl=TRUE))
960 :     }
961 :     ############
962 : markus 396 mm.examples.from.testfile=function
963 :     ### extract examples from external files
964 :     (name,inlinedocs.exampleDir,inlinedocs.exampleTrunk,...){
965 :     tsubdir <-inlinedocs.exampleDir
966 :     trunk<- inlinedocs.exampleTrunk
967 :     if (is.null(tsubdir)) {
968 :     return(list())# do nothing
969 :     }
970 :     p <- paste(trunk,name,".R",sep="")
971 : markus 394 allfiles=dir(tsubdir)
972 : markus 396 L<- allfiles[grepl(pattern=p,allfiles,fixed=TRUE)]
973 : markus 394 path=function(l){file.path(tsubdir,l)}
974 :     paths=lapply(L,path)
975 :     print(lapply(paths,file.exists))
976 :    
977 : markus 396 res=list()
978 : markus 394 if(length(L)>0){
979 :     exampleTexts= lapply(paths,readLines)
980 :     combinedText <- unlist(exampleTexts)
981 : markus 396 res[["examples"]]=combinedText
982 :     ##pp("res",environment())
983 : markus 394
984 :     }
985 : markus 396 res
986 : markus 394 }
987 : tdhock 154 ### Parsers for each function that are constructed automatically. This
988 :     ### is a named list, and each element is a parser function for an
989 :     ### individual object.
990 :     forfun.parsers <-
991 :     list(prefixed.lines=prefixed.lines,
992 :     extract.xxx.chunks=extract.xxx.chunks,
993 : markus 394 title.from.firstline=title.from.firstline,
994 : tdhock 154 ## PhG: it is tests/FUN.R!!! I would like more flexibility here
995 :     ## please, let me choose which dir to use for examples!
996 :     ## Get examples for FUN from the file tests/FUN.R
997 :     examples.from.testfile=function(name,...){
998 :     tsubdir <- getOption("inlinedocs.exdir")
999 :     if (is.null(tsubdir)) tsubdir <- "tests" # Default value
1000 :     tfile <- file.path("..",tsubdir,paste(name,".R",sep=""))
1001 : markus 396 print(file.exists(tfile))
1002 : markus 394 if(file.exists(tfile)){
1003 : tdhock 185 list(examples=readLines(tfile))
1004 : markus 396 }
1005 : tdhock 154 else list()
1006 :     },
1007 : markus 394 mm.examples.from.testfile=mm.examples.from.testfile,
1008 :     definition.from.source=definition.from.source
1009 : tdhock 196 )
1010 : tdhock 154
1011 : markus 396 extract.docs<-function
1012 :     ### produce doc link instances
1013 :     (parsed,objs,on){
1014 :     ##pp("on",environment())
1015 : markus 394 extract.docs.try <-function(o,on)
1016 : tdhock 154 {
1017 :     ## Note: we could use parsed information here too, but that
1018 : tomaschwut 393 ## would produce different results for R.methodsS3::setMethodS3 etc.
1019 : tdhock 154 doc <- list()
1020 :     if ( !is.null(parsed[[on]]) ){
1021 :     if ( !is.na(parsed[[on]]@code[1]) ){ # no code given for generics
1022 : tdhock 185 doc$definition <- paste(parsed[[on]]@code)
1023 : tdhock 154 }
1024 :     if(!"description"%in%names(doc) && !is.na(parsed[[on]]@description) ){
1025 :     doc$description <- parsed[[on]]@description
1026 :     }
1027 : tomaschwut 393 ## if ( "R.methodsS3::setMethodS3" == parsed[[on]]@created ){
1028 : kmpont 212 ## gen <- leadingS3generic(on,topenv())
1029 :     ## if ( 0 < length(gen) ){
1030 :     ## doc$.s3method <- gen$.s3method
1031 :     ## cat("S3method(",gen$.s3method[1],",",gen$.s3method[2],")\n",sep="")
1032 :     ## }
1033 :     ## }
1034 : tdhock 154 }
1035 :     if("title" %in% names(doc) && !"description" %in% names(doc) ){
1036 :     ## For short functions having both would duplicate, but a
1037 :     ## description is required. Therefore automatically copy title
1038 :     ## across to avoid errors at package build time.
1039 :     doc$description <- doc$title
1040 :     }
1041 :     doc
1042 :     }
1043 :     res <- try({o <- objs[[on]]
1044 :     extract.docs.try(o, on)},FALSE)
1045 :     if(class(res)=="try-error"){
1046 :     cat("Failed to extract docs for: ",on,"\n\n")
1047 :     list()
1048 :     } else if(0 == length(res) && inherits(objs[[on]],"standardGeneric")){
1049 :     NULL
1050 :     } else if(0 == length(res) && "function" %in% class(o)
1051 : tdhock 302 && 1 == length(osource <- getSource(o))
1052 : tdhock 191 && grepl(paste("UseMethod(",on,")",sep="\""),osource)
1053 : tdhock 154 ){
1054 :     ## phew - this should only pick up R.oo S3 generic definitions like:
1055 :     ## attr(*, "source")= chr "function(...) UseMethod(\"select\")"
1056 :     NULL
1057 :     } else res
1058 :     }
1059 : markus 394
1060 :     inherit.docs <- function(
1061 : markus 396 ### recursively add documentation inherited from doc.link parents
1062 : markus 394 parsed, ##<< a list of doc.link objects
1063 :     res, ##<< the list of documentation to be extended
1064 :     childName ##<< the name of the object who possibly inherits
1065 :     ){
1066 :     in.res <- res[[childName]] #start with the present
1067 : markus 396 ##pp("in.res",environment())
1068 : markus 394 childsDocLink <-parsed[[childName]]
1069 :     if ( !is.null(childsDocLink) ){
1070 :     for ( parent in childsDocLink@parent ){
1071 :     if ( !is.na(parent) ){
1072 : markus 396 ##pp("parent",environment())
1073 : markus 394 #pe(quote(names(res)),environment())
1074 :     #pe(quote(parent %in% names(res)),environment())
1075 :     if ( is.null(in.res) ){
1076 :     in.res <- res[[parent]]
1077 :     } else if ( parent %in% names(res) ){
1078 :     parent.docs <- res[[parent]]
1079 :     for ( nn in names(parent.docs) ){
1080 :     if ( !nn %in% names(in.res) ){
1081 :     in.res[[nn]] <- parent.docs[[nn]]
1082 :     }
1083 :     }
1084 :     }
1085 :     }
1086 :     }
1087 :     }
1088 :     invisible(in.res)
1089 :     ### the possibly extended list of documentation
1090 :     }
1091 : markus 396
1092 :    
1093 :     extra.method.docs <- function
1094 :     ### can be used in the parser list of package.skeleton.dx(). TODO:
1095 :     (code,
1096 :     ### Code lines in a character vector containing multiple R objects to
1097 :     ### parse for documentation.
1098 :     objs,
1099 :     ### The objects defined in the code.
1100 :     env,
1101 :     ### The environment they inhibit (needed to pass on)
1102 :     inlinedocs.exampleDir,
1103 :     ### A string pointing to the location where inlinedocs should search for external examples
1104 :     inlinedocs.exampleTrunk,
1105 :     ### A string used to identify the files containing external examples in the example directory. All file names of external examples have to start with this string
1106 :     ...
1107 :     ### ignored
1108 :     ){
1109 :     doc.names <- names(objs)
1110 :     parsed <- extract.file.parse(code,env)
1111 :     res=list()
1112 :     for ( nn in names(parsed) ){
1113 :     dL=parsed[[nn]]
1114 :     if ( dL@created == "setMethod" ){
1115 :     S4Method.docs <- extract.docs.setMethod(dL,env,inlinedocs.exampleDir,inlinedocs.exampleTrunk)
1116 :     docname <- dL@name
1117 :     if ( is.null(res[[docname]]) ){
1118 :     res[[docname]] <- S4Method.docs
1119 :     doc.names <- c(doc.names,docname)
1120 :     } else {
1121 :     stop(nn," appears as both S4 method and some other definition")
1122 :     }
1123 :     }
1124 :     }
1125 :     all.done <- FALSE
1126 :     while ( !all.done ){
1127 :     res1 <- sapply(doc.names,inherit.docs,parsed=parsed,res=res,simplify=FALSE)
1128 :     all.done <- identical(res1,res)
1129 :     res <- res1
1130 :     }
1131 :     res
1132 :     ### named list of lists, one for each object to document.
1133 :     }
1134 :    
1135 :    
1136 :    
1137 : markus 394 extra.class.docs <- function # Extract documentation from code chunks
1138 :     ### Parse R code to extract inline documentation from comments around
1139 :     ### each class
1140 :     ### looking at the "source" attribute. This is a Parser Function that
1141 :     ### can be used in the parser list of package.skeleton.dx(). TODO:
1142 :     (code,
1143 :     ### Code lines in a character vector containing multiple R objects to
1144 :     ### parse for documentation.
1145 :     objs,
1146 :     ### The objects defined in the code.
1147 :     env,
1148 :     ### The environment they inhibit (needed to pass on)
1149 :     ...
1150 :     ### ignored
1151 :     ){
1152 : tdhock 154 doc.names <- names(objs)
1153 : markus 394 parsed <- extract.file.parse(code,env)
1154 :     res=list()
1155 : tdhock 154 for ( nn in names(parsed) ){
1156 :     if ( parsed[[nn]]@created == "setClass" ){
1157 :     S4class.docs <- extract.docs.setClass(parsed[[nn]])
1158 :     docname <- paste(nn,"class",sep="-")
1159 :     if ( is.null(res[[docname]]) ){
1160 :     res[[docname]] <- S4class.docs
1161 :     doc.names <- c(doc.names,docname)
1162 :     } else {
1163 :     stop(nn," appears as both S4 class and some other definition")
1164 :     }
1165 :     }
1166 :     }
1167 : markus 394 all.done <- FALSE
1168 :     while ( !all.done ){
1169 :     res1 <- sapply(doc.names,inherit.docs,parsed=parsed,res=res,simplify=FALSE)
1170 :     all.done <- identical(res1,res)
1171 :     res <- res1
1172 : tdhock 154 }
1173 : markus 394 res
1174 :     ### named list of lists, one for each object to document.
1175 :     }
1176 :     extra.code.docs <- function # Extract documentation from code chunks
1177 :     ### Parse R code to extract inline documentation from comments around
1178 :     ### each function. These are not able to be retreived simply by
1179 :     ### looking at the "source" attribute. This is a Parser Function that
1180 :     ### can be used in the parser list of package.skeleton.dx(). TODO:
1181 :     ### Modularize this into separate Parsers Functions for S4 classes,
1182 :     ### prefixes, ##<<blocks, etc. Right now it is not very clean!
1183 :     (code,
1184 :     ### Code lines in a character vector containing multiple R objects to
1185 :     ### parse for documentation.
1186 :     objs,
1187 :     ### The objects defined in the code.
1188 :     env, # the environment
1189 :     ...
1190 :     ### ignored
1191 :     ){
1192 :     parsed <- extract.file.parse(code,env)
1193 :     doc.names <- names(objs)
1194 :     res <- sapply(doc.names,extract.docs,parsed=parsed,objs=objs,simplify=FALSE)
1195 : tdhock 154 all.done <- FALSE
1196 :     while ( !all.done ){
1197 : markus 394 res1 <- sapply(doc.names,inherit.docs,parsed=parsed,res=res,simplify=FALSE)
1198 : tdhock 154 all.done <- identical(res1,res)
1199 :     res <- res1
1200 :     }
1201 :     ## now strip out any generics (which have value NULL in res):
1202 :     res.not.null <- sapply(res,function(x){!is.null(x)})
1203 :     if ( 0 < length(res.not.null) && length(res.not.null) < length(res) ){
1204 :     res <- res[res.not.null]
1205 :     }
1206 :     res
1207 :     ### named list of lists, one for each object to document.
1208 :     }
1209 : markus 394 ### List of Parser Functions that can be applied to any object.
1210 :     forall.parsers <-
1211 :     list(## Fill in author from DESCRIPTION and titles.
1212 :     author.from.description=function(desc,...){
1213 :     list(author=desc[,"Author"])
1214 :     },
1215 :     ## The format section sometimes causes problems, so erase it.
1216 :     erase.format=function(...){
1217 :     list(format="")
1218 :     },
1219 :     ## Convert the function name to a title.
1220 :     title.from.name=function(name,doc,...){
1221 :     if("title"%in%names(doc))list() else
1222 :     list(title=gsub("[._]"," ",name))
1223 :     },
1224 :     ## PhG: here is what I propose for examples code in the 'ex' attribute
1225 :     examples.in.attr = function (name, o, ...) {
1226 : markus 396 ex <- attr(o, "ex",exact=TRUE)
1227 : markus 394 if (!is.null(ex)) {
1228 :     ## Special case for code contained in a function
1229 :     if (inherits(ex, "function")) {
1230 :     ## If source is available, start from there
1231 :     src <- getSource(ex)
1232 :     if (!is.null(src)) {
1233 :     ex <- src
1234 :     } else { ## Use the body of the function
1235 :     ex <- deparse(body(ex))
1236 :     }
1237 :     ## Eliminate leading and trailing code
1238 :     ex <- ex[-c(1, length(ex))]
1239 :     if( length(ex) ){ # avoid error on yet empty example
1240 :     if(ex[1]=="{")ex <- ex[-1]
1241 :     ## all the prefixes
1242 :     ex <- kill.prefix.whitespace(ex)
1243 :     }
1244 :     ## Add an empty line before and after example
1245 :     ex <- c("", ex, "")
1246 :     }
1247 :     list(examples = ex)
1248 :     } else list()
1249 :     },collapse=function(doc,...){
1250 :     L <- lapply(doc,paste,collapse="\n")
1251 :     L$.overwrite <- TRUE
1252 :     L
1253 :     },tag.s3methods=leadingS3generic
1254 :     )
1255 : tdhock 154
1256 : markus 394 ### List of parser functions that operate on single objects. This list
1257 :     ### is useful for testing these functions.
1258 :     lonely <- structure(c(forall.parsers,forfun.parsers),ex=function(){
1259 :     f <- function # title
1260 :     ### description
1261 :     (x, ##<< arg x
1262 :     y
1263 :     ### arg y
1264 :     ){
1265 :     ##value<< a list with elements
1266 :     list(x=x, ##<< original x value
1267 :     y=y, ##<< original y value
1268 :     sum=x+y) ##<< their sum
1269 :     ##end<<
1270 :     }
1271 :     src <- getSource(f)
1272 :     lonely$extract.xxx.chunks(src)
1273 :     lonely$prefixed.lines(src)
1274 :     })
1275 :    
1276 :    
1277 : tdhock 154 ### List of parsers to use by default with package.skeleton.dx.
1278 :     default.parsers <-
1279 : markus 394 c(
1280 : markus 396 extra.class.docs=extra.class.docs, ## TODO: cleanup!
1281 :     extra.method.docs=extra.method.docs, ## TODO: cleanup!
1282 : markus 394 extra.code.docs=extra.code.docs, ## TODO: cleanup!
1283 : tdhock 154 sapply(forfun.parsers,forfun),
1284 :     edit.package.file=function(desc,...){
1285 :     in.details <- setdiff(colnames(desc),"Description")
1286 : tdhock 185 details <- sprintf("%s: \\tab %s\\cr",in.details,desc[,in.details])
1287 : tdhock 154 L <-
1288 :     list(list(title=desc[,"Title"],
1289 :     description=desc[,"Description"],
1290 : tdhock 195 `tabular{ll}`=details))
1291 : tdhock 154 names(L) <- paste(desc[,"Package"],"-package",sep="")
1292 :     L
1293 : tdhock 197 },
1294 :     sapply(forall.parsers,forall)
1295 : tdhock 186 )
1296 : tdhock 154
1297 : tdhock 87 setClass("DocLink", # Link documentation among related functions
1298 :     ### The \code{.DocLink} class provides the basis for hooking together
1299 :     ### documentation of related classes/functions/objects. The aim is that
1300 : kmpont 212 ### documentation sections missing from the child are inherited from
1301 :     ### the parent class.
1302 : tdhock 87 representation(name="character", ##<< name of object
1303 :     created="character", ##<< how created
1304 :     parent="character", ##<< parent class or NA
1305 :     code="character", ##<< actual source lines
1306 :     description="character") ##<< preceding description block
1307 :     )
1308 :    
1309 :     extract.file.parse <- function # File content analysis
1310 : tdhock 356 ### Using the base \code{parse} function, analyse the file to link
1311 : tdhock 87 ### preceding "prefix" comments to each active chunk. Those comments form
1312 :     ### the default description for that chunk. The analysis also looks for
1313 : markus 394 ### S4 class "setClass" ,R.oo setConstructorS3 R.methodsS3::setMethodS3
1314 :     ### or S4 setMethod calls in order to link the documentation of those properly.
1315 :     (code,
1316 : tdhock 87 ### Lines of R source code in a character vector - note that any
1317 :     ### nested \code{source} statements are \emph{ignored} when scanning
1318 :     ### for class definitions.
1319 : markus 394 env
1320 :     ### the environment in which the code has been evaluated before.
1321 :     ### This is e.g. iportant to make sure that we can evaluate expressions
1322 :     ### like signature definitions for methods
1323 : tdhock 87 ){
1324 :     res <- list()
1325 :     old.opt <- options(keep.source=TRUE)
1326 :     parsed <- try(parse(text=code))
1327 :     options(old.opt)
1328 :     if ( inherits(parsed,"try-error") ){
1329 :     stop("parse failed with error:\n",parsed)
1330 :     }
1331 :     chunks <- attr(parsed,"srcref")
1332 :     last.end <- 0
1333 :     for ( k in 1:length(parsed) ){
1334 :     start <- chunks[[k]][1]
1335 :     ##details<< If the definition chunk does not contain a
1336 :     ## description, any immediately preceding sequence consecutive
1337 :     ## "prefix" lines will be used instead.
1338 :     default.description <- NULL
1339 :     while ( start > last.end+1
1340 : tdhock 191 && grepl(prefix,code[start-1],perl=TRUE) ){
1341 : tdhock 87 start <- start-1
1342 :     }
1343 :     if ( start < chunks[[k]][1] ){
1344 :     default.description <- decomment(code[start:(chunks[[k]][1]-1)])
1345 :     } else {
1346 :     default.description <- NA_character_;
1347 :     }
1348 :     ##details<< Class and method definitions can take several forms,
1349 :     ## determined by expression type: \describe{
1350 :     ## \item{assignment (<-)}{Ordinary assignment of value/function;}
1351 :     ## \item{setClass}{Definition of S4 class;}
1352 : markus 394 ## \item{setMethod}{Definition of a method of a S4 generic;}
1353 : tdhock 87 ## \item{setConstructorS3}{Definition of S3 class using R.oo package;}
1354 : tomaschwut 393 ## \item{R.methodsS3::setMethodS3}{Definition of method for S3 class using R.oo package.}}
1355 : tdhock 87 ## Additionally, the value may be a name of a function defined elsewhere,
1356 :     ## in which case the documentation should be copied from that other definition.
1357 :     ## This is handled using the concept of documentation links.
1358 :     lang <- parsed[[k]]
1359 :     chars <- as.character(lang)
1360 :     expr.type <- chars[1]
1361 :     parent <- NA_character_
1362 :    
1363 : markus 394 if ( expr.type == "<-" || expr.type == "setConstructorS3" ){
1364 : tdhock 87 object.name <- chars[2]
1365 :     ## If the function definition is not embedded within the call, then
1366 :     ## the parent is that function. Test whether the the third value
1367 :     ## looks like a name and add it to parents if so.
1368 : tdhock 191 if ( grepl("^[\\._\\w]+$",chars[3],perl=TRUE) ){
1369 : tdhock 87 parent <- chars[3]
1370 :     }
1371 :     res[[object.name]] <- new("DocLink",name=object.name,
1372 :     created=expr.type,
1373 :     parent=parent,
1374 :     code=paste(chunks[[k]],sep=""),
1375 :     description=default.description)
1376 : markus 394 } else if ( expr.type == "setClass" ){
1377 :     object.name <- chars[2]
1378 :     res[[object.name]] <- new("DocLink",name=object.name,
1379 :     created=expr.type,
1380 :     parent=parent,
1381 :     code=paste(chunks[[k]],sep=""),
1382 :     description=default.description)
1383 :    
1384 :     }
1385 :     else if ( expr.type == "R.methodsS3::setMethodS3" || expr.type == "R.methodsS3::R.methodsS3::setMethodS3"){
1386 : tomaschwut 393 ##details<< The \code{R.methodsS3::setMethodS3} calls introduce additional
1387 : tdhock 87 ## complexity: they will define an additional S3 generic (which
1388 :     ## needs documentation to avoid warnings at package build time)
1389 :     ## unless one already exists. This also is handled by "linking"
1390 : markus 394 ## documentation. A previously unseen S3generic is linked to the
1391 :     ## first defining instances, subsequent definitions of that S3generic
1392 : tdhock 87 ## also link back to the first defining instance.
1393 : markus 394 S3generic.name <- chars[2]
1394 :     object.name <- paste(S3generic.name,chars[3],sep=".")
1395 :     if ( is.null(res[[S3generic.name]]) ){
1396 :     ## TDH 9 April 2012 Do NOT add \\link in S3generic.desc below,
1397 : tdhock 356 ## since it causes problems on R CMD check.
1398 :     ##* checking Rd cross-references ... WARNING
1399 :     ##Error in find.package(package, lib.loc) :
1400 :     ## there is no package called ‘MASS’
1401 :     ##Calls: <Anonymous> -> lapply -> FUN -> find.package
1402 :    
1403 : markus 394 S3generic.desc <-
1404 : tdhock 356 paste("Generic method behind \\code{",object.name,"}",sep="")
1405 : markus 394 res[[S3generic.name]] <- new("DocLink",
1406 :     name=S3generic.name,
1407 : tdhock 87 created=expr.type,
1408 :     parent=object.name,
1409 :     code=NA_character_,
1410 : markus 394 description=S3generic.desc)
1411 : tdhock 87 } else {
1412 : markus 394 parent <- res[[S3generic.name]]@parent
1413 : tdhock 87 }
1414 :     ## If the function definition is not embedded within the call, then
1415 :     ## the parent is that function. Test whether the the fourth value
1416 :     ## looks like a name and add it to parents if so.
1417 : tdhock 191 if ( grepl("^[\\._\\w]+$",chars[4],perl=TRUE) ){
1418 : tdhock 87 parent <- c(chars[4],parent)
1419 :     }
1420 :     res[[object.name]] <- new("DocLink",name=object.name,
1421 :     created=expr.type,
1422 :     parent=parent,
1423 :     code=paste(chunks[[k]],sep=""),
1424 :     description=default.description)
1425 : markus 394 } else if (expr.type == "setMethod" ) {
1426 :    
1427 : markus 396 NamedArgs=rewriteSetMethodArgs(lang)
1428 : markus 394 genName=NamedArgs[["f"]]
1429 :     sigexp=NamedArgs[["signature"]]
1430 :     sig=eval(sigexp,env)
1431 : markus 396 N <- methodDocName(genName,sig)
1432 : markus 394 object.name <- N
1433 :    
1434 :     ## If the function definition is not embedded within the call, then
1435 :     ## the parent is that function. Test whether the value for "definition"
1436 :     ## looks like a funktion name and add it to parents if so.
1437 :     def=paste(as.character(NamedArgs[["definition"]]),collapse="\n")
1438 :     if ( grepl("^[\\._\\w]+$",def,perl=TRUE) ){
1439 :     parent <- def
1440 :     }
1441 :     res[[object.name]] <- new("DocLink",name=object.name,
1442 :     created=expr.type,
1443 :     parent=parent,
1444 :     code=paste(chunks[[k]],sep=""),
1445 :     description=default.description)
1446 :     }else {
1447 :     ## Not sure what to do with these yet. Need to deal with setAs etc.
1448 : tdhock 87 }
1449 :     }
1450 :     invisible(res)
1451 :     ### Returns an invisible list of .DocLink objects.
1452 :     }
1453 :    
1454 :     extract.docs.setClass <- function # S4 class inline documentation
1455 :     ### Using the same conventions as for functions, definitions of S4 classes
1456 :     ### in the form \code{setClass("classname",\dots)} are also located and
1457 :     ### scanned for inline comments.
1458 : tdhock 93 (doc.link
1459 : tdhock 356 ### DocLink object as created by \code{extract.file.parse}.
1460 : tdhock 87 ### Note that \code{source} statements are \emph{ignored} when scanning for
1461 :     ### class definitions.
1462 : tdhock 93 ){
1463 : tdhock 87 chunk.source <- doc.link@code
1464 :     ##details<<
1465 :     ## Extraction of S4 class documentation is currently limited to expressions
1466 :     ## within the source code which have first line starting with
1467 :     ## \code{setClass("classname"}. These are located from the source file
1468 :     ## (allowing also for white space around the \code{setClass} and \code{(}).
1469 :     ## Note that \code{"classname"} must be a quoted character string;
1470 :     ## expressions returning such a string are not matched.
1471 :     class.name <- doc.link@name
1472 :    
1473 :     ##details<< For class definitions, the slots (elements of the
1474 :     ## \code{representation} list) fill the role of function
1475 :     ## arguments, so may be documented by \code{##<<} comments on
1476 :     ## the same line or \code{### } comments at the beginning of the
1477 :     ## following line.
1478 :     f.n <- paste(class.name,"class",sep="-")
1479 : tdhock 154 docs <- extract.xxx.chunks(chunk.source,f.n)
1480 : tdhock 138 ## also apply source parsing functions that I separated out into
1481 :     ## separate functions
1482 :     docs <- combine(docs,lonely$prefixed.lines(chunk.source))
1483 :     docs$title <- lonely$title.from.firstline(chunk.source)
1484 : tdhock 87 ##details<<
1485 : kmpont 305 ## If there is no explicit title on the first line of setClass, then
1486 :     ## one is made up from the class name.
1487 :     if ( 0 == length(docs$title) ){
1488 :     docs$title <- list(title=paste(class.name,"S4 class"))
1489 :     }
1490 :     ##details<<
1491 : tdhock 87 ## The class definition skeleton includes an \code{Objects from the Class}
1492 :     ## section, to which any \code{##details<<} documentation chunks are
1493 :     ## written. It is given a vanilla content if there are no specific
1494 :     ## \code{##details<<} documentation chunks.
1495 :     if ( is.null(docs[["details"]]) ){
1496 :     docs[["details"]] <-
1497 :     paste("Objects can be created by calls of the form \\code{new(",
1498 :     class.name," ...)}",sep="")
1499 :     }
1500 :     docs[["section{Objects from the Class}"]] <- docs[["details"]]
1501 :     ## seealso has a skeleton line not marked by ~ .. ~, so have to suppress
1502 :     if ( is.null(docs[["seealso"]]) ){
1503 :     docs[["seealso"]] <- ""
1504 :     }
1505 :     if ( is.null(docs[["alias"]]) ){
1506 :     docs[["alias"]] <- class.name
1507 :     }
1508 :     if ( is.null(docs[["description"]]) ){
1509 :     docs[["description"]] <- doc.link@description
1510 :     }
1511 :     invisible(docs)
1512 :     }
1513 : markus 396 extract.docs.setMethod<- function # S4 mehtod inline documentation
1514 :     ### Using the same conventions as for functions, definitions of S4 methods
1515 :     ### in the form \code{setMethod(\dots)} are also located and
1516 :     ### scanned for inline comments.
1517 :    
1518 :     (doc.link,
1519 :     ### DocLink object as created by \code{extract.file.parse}.
1520 :     env,
1521 :     ### environment to find method source
1522 :     inlinedocs.exampleDir,
1523 :     ### A string pointing to the location where inlinedocs should search for external examples
1524 :     inlinedocs.exampleTrunk
1525 :     ### A regular expression used to identify the files containing external examples in the example directory
1526 :     ){
1527 :     funcSource=getMethodSrc(doc.link,env)
1528 :     method.name=getMethodName(doc.link,env)
1529 :     ##pp("funcSource",environment())
1530 :     docs=list()
1531 :     docs<- combine(docs,prefixed.lines(funcSource))
1532 :     ##pp("docs",environment())
1533 :     docs <- combine(docs,extract.xxx.chunks(funcSource,method.name))
1534 :     ##pp("docs",environment())
1535 :     docs <- combine(docs,title.from.firstline(funcSource,method.name))
1536 :     ##pp("docs",environment())
1537 :     docs <- combine(docs,mm.examples.from.testfile(method.name,inlinedocs.exampleDir,inlinedocs.exampleTrunk))
1538 :     docs
1539 :     }
1540 : markus 394 createObjects <- function(code){
1541 : markus 396 ### the function creates the environment object lists and expression by parsing all the code files
1542 :     ### Is is factored out to make writing tests easier
1543 :     ### since we often need the objects and the environment
1544 :     ### they inhabit
1545 : tdhock 105 e <- new.env()
1546 : kmpont 212 ## KMP 2011-03-09 fix problem with DocLink when inlinedocs ran on itself
1547 :     ## Error in assignClassDef(Class, classDef, where) :
1548 :     ## Class "DocLink" has a locked definition in package "inlinedocs"
1549 :     ## Traced to "where" argument in setClassDef which defaults to topenv()
1550 :     ## which in turn is inlinedocs when processing inlinedocs package, hence
1551 :     ## the clash. The following works (under R 2.12.2), so that the topenv()
1552 :     ## now finds e before finding the inlinedocs environment.
1553 : markus 396
1554 :     #old <- options(keep.source=TRUE,topLevelEnvironment=e)
1555 :     old <- options(topLevelEnvironment=e)
1556 : tdhock 109 on.exit(options(old))
1557 : markus 396 exprs <- parse(text=code,keep.source=TRUE)
1558 : tdhock 248 ## TDH 2011-04-07 set this so that no warnings about creating a fake
1559 :     ## package when we try to process S4 classes defined in code
1560 :     e$.packageName <- "inlinedocs.processor"
1561 : tdhock 152 for (i in exprs){
1562 : tdhock 248 eval(i, e)
1563 : tdhock 152 }
1564 : markus 394 objs <- sapply(ls(e),get,e,simplify=FALSE) # note that ls will not find S4 classes nor methods for generic functions
1565 :     list(objs=objs,env=e,exprs=exprs)
1566 :     }
1567 : tdhock 105
1568 : markus 394
1569 :     apply.parsers<- function
1570 :     ### Parse code to r objs, then run all the parsers and return the
1571 :     ### documentation list.
1572 :     (code,
1573 :     ### Character vector of code lines.
1574 :     parsers=default.parsers,
1575 :     ### List of Parser Functions.
1576 :     verbose=FALSE,
1577 :     ### Echo names of Parser Functions?
1578 : markus 396 inlinedocs.exampleDir,
1579 :     ### A string pointing to the location where inlinedocs should search for external examples
1580 :     inlinedocs.exampleTrunk,
1581 :     ### A string used to identify the files containing external examples in the example directory. All file names of external examples have to start with this string
1582 : markus 394 ...
1583 :     ### Additional arguments to pass to Parser Functions.
1584 :     ){
1585 : markus 396 l=createObjects(code)# note that ls will not find S4 classes nor methods for generic functions
1586 : markus 394 objs=l[["objs"]]
1587 :     e=l[["env"]]
1588 :     exprs=l[["exprs"]]
1589 : tdhock 105 docs <- list()
1590 : kmpont 305
1591 : tdhock 109 ## apply parsers in sequence to code and objs
1592 : tdhock 312 if(verbose)cat("Applying parsers:\n")
1593 : tdhock 105 for(i in seq_along(parsers)){
1594 :     N <- names(parsers[i])
1595 : markus 394 if(verbose){
1596 : tdhock 105 if(is.character(N) && N!=""){
1597 : markus 370 cat(" this is parser:",N,"\n",sep="")
1598 : tdhock 312 }else cat('.\n')
1599 : markus 394 }
1600 : tdhock 105 p <- parsers[[i]]
1601 :     ## This is the argument list that each parser receives:
1602 : markus 396 L <- p(
1603 :     code=code,
1604 :     objs=objs,
1605 :     docs=docs,
1606 :     env=e,
1607 :     inlinedocs.exampleDir=inlinedocs.exampleDir,
1608 :     inlinedocs.exampleTrunk=inlinedocs.exampleTrunk,
1609 :     ...
1610 :     )
1611 : markus 394 docs <- combine(docs,L)
1612 : tdhock 105 }
1613 : tdhock 196 ## post-process to collapse all character vectors
1614 :     for(i in seq_along(docs)){
1615 :     for(j in seq_along(docs[[i]])){
1616 : tdhock 198 if(names(docs[[i]])[j]!=".s3method")
1617 : tdhock 196 docs[[i]][[j]] <- paste(docs[[i]][[j]],collapse="\n")
1618 :     }
1619 : markus 324 }
1620 : tdhock 105 if(verbose)cat("\n")
1621 : markus 394
1622 : markus 396 return(list(docs=docs,env=e,objs=objs,exprs=exprs))
1623 : tdhock 105 ### A list of extracted documentation from code.
1624 :     }
1625 : tdhock 109
1626 : tdhock 138 ### Names of Parser Functions that operate on the desc arg.
1627 :     descfile.names <- c("author.from.description","edit.package.file")
1628 :    
1629 :     ### Names of Parser Functions that do NOT use the desc arg.
1630 :     non.descfile.names <-
1631 :     names(default.parsers)[!names(default.parsers)%in%descfile.names]
1632 :    
1633 : tdhock 118 ### Parsers that operate only on R code, independently of the
1634 :     ### description file.
1635 : tdhock 138 nondesc.parsers <- default.parsers[non.descfile.names]
1636 : tdhock 118
1637 : tdhock 209 extract.docs.file <- structure(function
1638 : tdhock 109 ### Apply all parsers relevant to extract info from just 1 code file.
1639 :     (f,
1640 :     ### File name of R code to read and parse.
1641 : tdhock 203 parsers=NULL,
1642 : tdhock 109 ### Parser Functions to use to parse the code and extract
1643 :     ### documentation.
1644 : markus 396 inlinedocs.exampleDir=file.path("..","..","inst","tests"),
1645 :     ### A string pointing to the location where inlinedocs should search for external examples
1646 :     inlinedocs.exampleTrunk="example.",
1647 :     ### A string used to identify the files containing external examples in the example directory. All file names of external examples have to start with this string
1648 : tdhock 109 ...
1649 :     ### Other arguments to pass to Parser Functions.
1650 :     ){
1651 : tdhock 203 if(is.null(parsers))parsers <- nondesc.parsers
1652 : markus 396 apply.parsers(
1653 :     readLines(f),
1654 :     parsers,
1655 :     verbose=FALSE,
1656 :     inlinedocs.exampleDir,
1657 :     inlinedocs.exampleTrunk,
1658 :     ...
1659 :     )[["docs"]]
1660 : tdhock 209 },ex=function(){
1661 :     f <- system.file("silly","R","silly.R",package="inlinedocs")
1662 : tdhock 248 extract.docs.file(f)
1663 : tdhock 209 })
1664 : tdhock 248

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge