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