1parse_pairlist <- function(x){
2    is.missing.arg <- function(arg) typeof(arg) == "symbol" && deparse(arg) == ""
3                                  # x == NULL corresponds to functions with no arguments (also
4                                  # length(NULL) is 0) also, NULL is a pairlist with length 0.
5                                           # Is this function used with x other than pairlist?
6    if(is.null(x) || length(x) == 0)       # If not, the test of length(x) is redundant.
7        return(list(argnames = character(0), defaults = character(0)))
8
9    nonmis <- x[ !sapply(x, is.missing.arg) ]
10    wrk <- character(length(nonmis))
11    names(wrk) <- names(nonmis)
12    for(s in names(nonmis)){
13        wrk[[s]] <- paste(deparse(nonmis[[s]], backtick = TRUE, width.cutoff = 500L)
14                          , collapse = "\n")
15    }
16    list(argnames = names(x), defaults = wrk )
17}
18                                                                   # 2012-10-03 new arg. infix
19pairlist2f_usage1 <- function(x, name, S3class = "", S4sig = "", infix = FALSE, fu = TRUE){
20    structure(c(list(name=name, S3class=S3class, S4sig=S4sig, infix=infix, fu = fu),
21                parse_pairlist(x)), class="f_usage")
22}
23
24print.f_usage <- function(x, ...){
25    tab <- max(nchar(names(x)))
26    for(nam in names(x)){
27        if(is.null(nam))
28            next
29        if(nam != "defaults")
30            cat(nam, strrep(" ", tab - nchar(nam)), "=", x[[nam]], "\n")
31        else{
32            defnams <- names(x$defaults)
33            for(i in seq_along(defnams)){
34                if(i == 1)
35                    cat(nam, strrep(" ", tab - nchar(nam[i])), ":", defnams[i], "=", x$defaults[i], "\n")
36                else
37                    cat(strrep(" ", tab + 3), defnams[i] , "=", x$defaults[i], "\n")
38
39            }
40        }
41    }
42    cat("\n")
43}
44
45format_funusage <- function(x, name = "", width = 72, realname){
46    res <- paste(name,  "(", paste(x, collapse = ", "),  ")", sep="")
47
48    if(is.numeric(width)  &&  nchar(res, type="width") > width){
49        delim <- c("(", rep(", ", length(x) - 1), ")")
50        wrk <- paste(c(name, x), delim, sep="")
51        lens <- nchar(wrk, type="width")
52        if(!missing(realname))
53            lens[1] <- nchar(realname, type="width") + 1
54        indent <- paste(rep(" ", lens[1]), collapse="")
55        res <- character(0)
56        curlen <- 0
57        for(i in seq_along(wrk)){
58            if(curlen + lens[i] > width){
59                res <- paste(res, "\n", indent,  sep="")
60                curlen <- lens[1]   #  = number of chars in `indent'
61            }
62            res <- paste(res, wrk[i], sep="")
63            curlen <- curlen + lens[i]
64        }
65    }
66    res
67}
68
69deparse_usage1 <- function(x, width = 72){
70    if(!x$fu) # a variable, not function
71        return( structure( x$name, names = x$name ) )
72          # todo: maybe x$name tryabva da e character, as.character here should not be needed.
73    if(as.character(x$name) %in% c("[","[[", "$", "@",  "[<-", "[[<-", "$<-",  "@<-", "!"))
74        "dummy"
75    else if(x$infix){  # infix operator
76        if(grepl(".+<-$", x$name)){ # name end is "<-" but is not equal to it
77            name2 <- sub("^(.+)<-$", "\\1", x$name)
78            m <- length(x$argnames)
79            res <- paste(name2, "(", paste(x$argnames[-m], collapse=", "), ")",
80                         "<-", x$argnames[m])
81        }else                               # todo: make sure  that the name is not in quotes!
82            res <- paste(x$argnames, collapse = paste0(" ", x$name, " "))
83
84        return(res)
85    }
86
87    res <- x$argnames
88    names(res) <- x$argnames
89
90    nams <- names(x$defaults)
91    res[nams] <- paste(res[nams], "=", x$defaults)
92
93    assop <- grepl(".+<-$", x$name) # name end is "<-" but is not equal to it
94    name <- x$name
95    if(assop){
96        name <- sub("<-$", "", x$name)
97        value <- res[length(res)]
98        res <- res[-length(res)]
99    }
100
101    res <- if(!identical(x$S3class, ""))
102               format_funusage(res, paste("\\method{", name, "}{", x$S3class, "}", sep=""),
103                               realname = name )
104           else if(!identical(x$S4sig, ""))
105               format_funusage(res, paste("\\S4method{", name, "}{",
106                                          paste0(x$S4sig, collapse = ", "),
107                                          "}", sep=""), realname = name )
108           else
109               switch(name,
110                      "$" =, "@" = paste0(res[1], name, res[2]),
111                      "[" =, "[[" = paste0(res[1], name, paste0(res[-1], collapse = ", "),
112                                                   .closeOp[name]),
113                      "!" = paste0("!", res[1]),
114                      ## default
115                      format_funusage(res, name)
116                      )
117
118    if(assop)           # if assignment, add to the last line, usually the only one
119        res[length(res)] <- paste0(res[length(res)], " <- ", value)
120                   # "[<-"  = paste0(res[1], "[", paste0(res[c(-1,-length(res))],
121                   #                        collapse = ", "), "]", " <- ", res[length(res)]),
122                   # "[[<-" = paste0(res[1], "[[", paste0(res[c(-1,-length(res))],
123                   #                        collapse = ", "), "]]", " <- ", res[length(res)]),
124                   # "$<-"  = paste0(res[1], "$", res[2], " <- ", res[3]),
125                   # "@<-"  = paste0(res[1], "@", res[2], " <- ", res[3]),
126
127    res <- gsub("...", "\\dots", res, fixed=TRUE)
128    structure( paste(res, collapse = ""), names=x$name )
129}
130
131as.character.f_usage <- function(x,...){
132    deparse_usage1(x)
133}
134
135deparse_usage <- function (x){
136    if(class(x) == "f_usage")
137        return(deparse_usage1(x))
138
139    nams <- names(x)
140    if(!is.null(nams))            # remove names since sapply merges them with the names of
141        names(x) <- NULL          # the list obtained by lapply()
142
143    res <- sapply(x, deparse_usage1)
144    if(is.null(names(res)))            # in most cases names(res) will be the same as nams
145        names(res) <- nams             # but give preference to the ones returned by
146                                       # deparse_usage1 which takes names from the objects.
147                                       # This `if' will hardly ever kick in...
148    res
149}
150
151.closeOp <- list("[" = "]", "[[" = "]]", "(" = ")", "{" = "}")
152