SCM

SCM Repository

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

Diff of /pkg/inlinedocs/R/parsers.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 158, Mon Nov 8 12:26:12 2010 UTC revision 186, Fri Jan 14 18:43:36 2011 UTC
# Line 8  Line 8 
8  ### combine lists by adding elements or adding to existing elements  ### combine lists by adding elements or adding to existing elements
9  combine.list <- function(x,y){  combine.list <- function(x,y){
10    toadd <- !names(y)%in%names(x)    toadd <- !names(y)%in%names(x)
11    toup <- names(y)[names(y)%in%names(x)]    toup <- names(y)[!toadd]
12      if("doc"%in%names(x))return(x$doc)
13      if("doc"%in%names(y))return(y$doc)
14    x[names(y)[toadd]] <- y[toadd]    x[names(y)[toadd]] <- y[toadd]
15    for(up in toup)x[[up]] <- combine(x[[up]],y[[up]])    for(up in toup)x[[up]] <- combine(x[[up]],y[[up]])
16    return(x)    return(x)
# Line 24  Line 26 
26  (comments  (comments
27  ### Character vector of prefixed comment lines.  ### Character vector of prefixed comment lines.
28   ){   ){
29    paste(gsub(prefix,"",comments),collapse="\n")    gsub(prefix,"",comments)
30  ### String without prefixes or newlines.  ### String without prefixes or newlines.
31  }  }
32    
33    forall <- function
34  ### For each object in the package that satisfies the criterion  ### For each object in the package that satisfies the criterion
35  ### checked by subfun, parse source using FUN and return the resulting  ### checked by subfun, parse source using FUN and return the resulting
36  ### documentation list.  ### documentation list.
 forall <- function  
37  (FUN,  (FUN,
38  ### Function to apply to each element in the package.  ### Function to apply to each element in the package.
39   subfun=function(x)TRUE   subfun=function(x)TRUE
# Line 43  Line 45 
45    f <- function(objs,docs,...){    f <- function(objs,docs,...){
46      objs <- objs[sapply(objs,subfun)]      objs <- objs[sapply(objs,subfun)]
47      L <- list()      L <- list()
48        on.exit(cat(sprintf("Parser Function failed on %s\n",N)))
49      for(N in names(docs)){      for(N in names(docs)){
50        o <- objs[[N]]        o <- objs[[N]]
51        L[[N]] <- FUN(src=attr(o,"source"),        L[[N]] <- FUN(src=attr(o,"source"),
52                      name=N,objs=objs,o=o,docs=docs,doc=docs[[N]],...)                      name=N,objs=objs,o=o,docs=docs,doc=docs[[N]],...)
53      }      }
54        on.exit()## remove warning message
55      L      L
56    }    }
57    class(f) <- c("allfun","function")    class(f) <- c("allfun","function")
# Line 67  Line 71 
71  ### For each function in the package, do something.  ### For each function in the package, do something.
72  forfun <- function(FUN)forall(FUN,is.function)  forfun <- function(FUN)forall(FUN,is.function)
73    
74    kill.prefix.whitespace <- function
75    ### Figure out what the whitespace preceding the example code is, and
76    ### then delete that from every line.
77    (ex
78    ### character vector of example code lines.
79     ){
80      tlines <- gsub("\\s*","",ex)
81      ##tlines <- gsub("#.*","",tlines)
82      prefixes <- unique(gsub("\\S.*","",ex[tlines!=""]))
83      FIND <- prefixes[which.min(nchar(prefixes))]
84      ## Eliminate leading tabulations or 2/4 spaces
85      sub(FIND, "", ex)
86    ### Character vector of code lines with preceding whitespace removed.
87    }
88    
89  examples.after.return <- function  examples.after.return <- function
90  ### Get examples from inline definitions after return()  ### Get examples from inline definitions after return()
91  ### PhG: this does not work well! Think of these situations:  ### PhG: this does not work well! Think of these situations:
# Line 111  Line 130 
130    ## Possibly eliminate a #}}} tag    ## Possibly eliminate a #}}} tag
131    ex <- ex[!grepl("#}}}", ex)]    ex <- ex[!grepl("#}}}", ex)]
132    ## Eliminate leading tabulations or four spaces    ## Eliminate leading tabulations or four spaces
133    prefixes <- gsub("(\\s*).*","\\1",ex,perl=TRUE)[grep("\\w",ex)]    ex <- kill.prefix.whitespace(ex)
   FIND <- prefixes[which.min(nchar(prefixes))]  
   ex <- sub(FIND,"",ex)  
134    ## Add an empty line before and after example    ## Add an empty line before and after example
135    ex <- c("", ex, "")    ex <- c("", ex, "")
136    ## Return examples and value    ## Return examples and value
137    list(examples = paste(ex, collapse = "\n"), value = value)    list(examples = ex, value = value)
138  }  }
139    
140  prefixed.lines <- function(src,...){  prefixed.lines <- structure(function(src,...){
141  ### The primary mechanism of inline documentation is via consecutive  ### The primary mechanism of inline documentation is via consecutive
142  ### groups of lines matching the specified prefix regular expression  ### groups of lines matching the specified prefix regular expression
143  ### "\code{^### }" (i.e. lines beginning with "\code{### }") are  ### "\code{^### }" (i.e. lines beginning with "\code{### }") are
# Line 136  Line 153 
153    starts <- c(1,bounds+1)    starts <- c(1,bounds+1)
154    ends <- c(bounds,length(clines))    ends <- c(bounds,length(clines))
155    ## detect body of function using paren matching    ## detect body of function using paren matching
156    f <- function(ch)cumsum(nchar(gsub(sprintf("[^%s]",ch),"",src)))    code <- gsub("#.*","",src)
157      f <- function(ch)cumsum(nchar(gsub(sprintf("[^%s]",ch),"",code)))
158    parens <- f("(")-f(")")    parens <- f("(")-f(")")
159    body.begin <- which(diff(parens)<0 & parens[-1]==0)+2    body.begin <- which(diff(parens)<0 & parens[-1]==0)+2
160      if(length(body.begin)==0)body.begin <- 1 ## rare cases
161    is.arg <- function(){    is.arg <- function(){
162      0 == length(grep("^\\s*#",src[start-1],perl=TRUE)) &&      gres <- grep("^\\s*#",src[start-1],perl=TRUE)
163        start<=body.begin      0 == length(gres) && start<=body.begin
164      }      }
165    res <- list()    res <- list()
166    for(i in seq_along(starts)){    for(i in seq_along(starts)){
167      start <- clines[starts[i]]      start <- clines[starts[i]]
168      end <- clines[ends[i]]      end <- clines[ends[i]]
169      lab <- if(end+1==length(src))"value"      lab <- if(all(grepl("^\\s*#",src[end:(length(src)-1)])))"value"
170      else if(start==2)"description"      else if(start==2)"description"
171      else if(is.arg()){      else if(is.arg()){
172        ##twutz: strip leading white spaces and brackets and ,        ##twutz: strip leading white spaces and brackets and ,
# Line 163  Line 182 
182      res[[lab]] <- decomment(src[start:end])      res[[lab]] <- decomment(src[start:end])
183    }    }
184    res    res
185  }  },ex=function(){
186    test <- function
187    ### the desc
188    (x,
189    ### the first argument
190     y ##<< another argument
191     ){
192      5
193    ### the return value
194    ##seealso<< foobar
195    }
196    src <- attr(test,"source")
197    prefixed.lines(src)
198    extract.xxx.chunks(src)
199    })
200    
201  extract.xxx.chunks <- function # Extract documentation from a function  extract.xxx.chunks <- function # Extract documentation from a function
202  ### Given source code of a function, return a list describing inline  ### Given source code of a function, return a list describing inline
# Line 430  Line 463 
463           if (is.null(tsubdir)) tsubdir <- "tests"       # Default value           if (is.null(tsubdir)) tsubdir <- "tests"       # Default value
464           tfile <- file.path("..",tsubdir,paste(name,".R",sep=""))           tfile <- file.path("..",tsubdir,paste(name,".R",sep=""))
465           if(file.exists(tfile))           if(file.exists(tfile))
466             list(examples=paste(readLines(tfile),collapse="\n"))             list(examples=readLines(tfile))
467           else list()           else list()
468         },         },
469         definition.from.source=function(doc,src,...){         definition.from.source=function(doc,src,...){
470           def <- doc$definition           def <- doc$definition
471           is.empty <- function(x)is.null(x)||x==""           is.empty <- function(x)is.null(x)||x==""
472           if(is.empty(def) && !is.empty(src))           if(is.empty(def) && !is.empty(src))
473             list(definition=paste(src,collapse="\n"))             list(definition=src)
474           else list()           else list()
475         })         })
476    
# Line 471  Line 504 
504               }               }
505               ## Eliminate leading and trailing code               ## Eliminate leading and trailing code
506               ex <- ex[-c(1, length(ex))]               ex <- ex[-c(1, length(ex))]
507               ## Eliminate leading tabulations or 2/4 spaces               ## all the prefixes
508               ex <- sub("^\t|    |  ", "", ex)               ex <- kill.prefix.whitespace(ex)
509               ## Add an empty line before and after example               ## Add an empty line before and after example
510               ex <- c("", ex, "")               ex <- c("", ex, "")
511             }             }
512             list(examples = paste(ex, collapse = "\n"))             list(examples = ex)
513           } else list()           } else list()
514           },
515           collapse.docs=function(doc,...){
516             list(doc=lapply(doc,paste,collapse="\n"))
517         })         })
518    
519  ### List of parser functions that operate on single objects. This list  ### List of parser functions that operate on single objects. This list
# Line 524  Line 560 
560        doc <- list()        doc <- list()
561        if ( !is.null(parsed[[on]]) ){        if ( !is.null(parsed[[on]]) ){
562          if ( !is.na(parsed[[on]]@code[1]) ){ # no code given for generics          if ( !is.na(parsed[[on]]@code[1]) ){ # no code given for generics
563            doc$definition <- paste(parsed[[on]]@code,collapse="\n")            doc$definition <- paste(parsed[[on]]@code)
564          }          }
565          if(!"description"%in%names(doc) && !is.na(parsed[[on]]@description) ){          if(!"description"%in%names(doc) && !is.na(parsed[[on]]@description) ){
566            doc$description <- parsed[[on]]@description            doc$description <- parsed[[on]]@description
# Line 622  Line 658 
658  default.parsers <-  default.parsers <-
659    c(extra.code.docs=extra.code.docs, ## TODO: cleanup!    c(extra.code.docs=extra.code.docs, ## TODO: cleanup!
660      sapply(forfun.parsers,forfun),      sapply(forfun.parsers,forfun),
     sapply(forall.parsers,forall),  
661      edit.package.file=function(desc,...){      edit.package.file=function(desc,...){
662        in.details <- setdiff(colnames(desc),"Description")        in.details <- setdiff(colnames(desc),"Description")
663        details <- paste(paste(in.details,": \\tab ",desc[,in.details],"\\cr",        details <- sprintf("%s: \\tab %s\\cr",in.details,desc[,in.details])
                              sep=""),collapse="\n")  
664        L <-        L <-
665          list(list(title=desc[,"Title"],          list(list(title=desc[,"Title"],
666                    description=desc[,"Description"],                    description=desc[,"Description"],
# Line 634  Line 668 
668                    author=desc[,"Maintainer"]))                    author=desc[,"Maintainer"]))
669        names(L) <- paste(desc[,"Package"],"-package",sep="")        names(L) <- paste(desc[,"Package"],"-package",sep="")
670        L        L
671      })      },
672        sapply(forall.parsers,forall)
673        )
674    
675  setClass("DocLink", # Link documentation among related functions  setClass("DocLink", # Link documentation among related functions
676  ### The \code{.DocLink} class provides the basis for hooking together  ### The \code{.DocLink} class provides the basis for hooking together

Legend:
Removed from v.158  
changed lines
  Added in v.186

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