1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
|
## 2018-02-07 new
ereprompt <- function(..., edit = TRUE, filename = TRUE){
reprompt(..., filename = filename, edit = edit)
}
## 2018-02-07 new argument `edit'
reprompt <- function(object, infile = NULL, Rdtext = NULL, final = TRUE,
type = NULL, package = NULL, methods = NULL, # for the call to promptMethods
verbose = TRUE, filename = NULL, sec_copy = TRUE, edit = FALSE, ...){
objmis <- missing(object)
tidyflag <- from_infile <- FALSE
# If 'object' is a string ending in ".Rd" and containing
# at least one "/", it is taken to be "infile"; a
# (somewhat dubious) convenience feature for the common
# mistake of omitting the name of the "infile" argument.
if(is.null(infile) && length(object) == 1 && is.character(object)
&& grepl("/.*[.][Rr]d$", object) )
infile <- object
if(!is.null(Rdtext)){ # process Rdtext, if present
if(is.null(infile)){
infile <- tempfile()
cat(Rdtext, file = infile, sep = "\n") # save parsed Rdtext to 'infile'
on.exit(unlink(infile))
}else
cat("both 'infile' and 'Rdtext' are given, ignoring Rdtext\n")
}
if(!objmis && inherits(object, "Rd")){
if(verbose) cat("Processing the Rd object...\n")
if(!is.null(infile))
cat("ignoring 'infile' and/or 'Rdtext' since 'object' is of class 'Rd'\n")
rdo <- object
}else if(!is.null(infile)){
if(verbose) cat("\nParsing the Rd documentation in file", infile, "...\n")
else cat("\n", basename(infile), ": ")
if(!file.exists(infile)){ # 2018-02-07 new
wrk <- try(rprojroot::find_root_file("man", basename(infile),
criterion = rprojroot::is_r_package),
silent = TRUE)
if(inherits(wrk, "try-error"))
stop("Input file ", infile, " not found")
else infile <- wrk
}
rdo <- permissive_parse_Rd(infile)
from_infile <- TRUE
}else{
if(verbose) cat("Rd source not supplied, looking for installed documentation.\n")
fnam <- if(is.character(object)) object else deparse(substitute(object))
rdo <- .capture_installed_help(fnam, type = type, package=package)
if(inherits(rdo,"try-error"))
cat("Rd source not supplied and installed documentation not found.\n")
else{
if(verbose) cat("Installed documentation found, processing it...\n")
rdo <- .order_sections(rdo) # the sections may not be in canonical order in
tidyflag <- TRUE # instaled help
}
}
if(inherits(rdo, "Rd")){ # do the main job: inspect the documentation object
res <- inspect_Rd(rdo, package = package)
}else{ # documentation not found, try to generate fresh one
if(verbose)
cat("Trying a 'prompt' function to generate documentation for the object.\n")
# 2012-11-04 arg. type, package
res <- .capture_promptAny(fnam, type = type, package = package,
final = final, methods = methods)
if(inherits(res,"try-error"))
stop("unsuccessful attempt to create Rd doc. using a 'prompt' function.")
else if (verbose)
cat("\tsuccess: documentation generated using a 'prompt' function.\n")
}
if(tidyflag)
res <- .Rd_tidy(res) # tidy() could do more,
if(is.null(filename)){ # generate appropriate file name; todo: may need some mangling?
filename <- if(is.null(infile))
paste(res[[ Rdo_which_tag_eq(res, "\\name") ]],
".Rd", sep="")
else basename(infile) # do not overwrite unless in the current dir
}else if(isTRUE(filename)){ # 2018-02-07 new
filename <- if(is.null(infile))
paste(res[[ Rdo_which_tag_eq(res, "\\name") ]],
".Rd", sep="")
else infile # will overwrite
}
# todo: error checking
if(is.character(filename) || identical(filename, FALSE)){ # convert to Rdtext
res <- Rdo2Rdf(res, ex_restore = TRUE,
file = if(is.character(filename)) filename else NULL,
srcfile = if(from_infile && sec_copy) infile else NULL )
if(is.character(filename))
res <- invisible(filename) # return only the file name in this case
}
if(edit && is.character(filename)){ ## 2018-02-07 new argument `edit'
file.edit(res) # TODO: check that it is a filename
res
}else
res
}
# (promptMethods) todo: filename = FALSE is a useful
# alternative. In that case the text is returned in a named list
# containing one element for each Rd section (multiple occurences
# of sections like '\alias' are grouped together.
# 2012-11-04 new arg. type, package
.capture_promptAny <- function(fnam, type, package, final, ..., methods){
# 2012-11-04 promenyam za da raboti is replacement methods, e.g. "[<--methods"
#
# if(grepl("^([^-]+)-.*", fnam)){ # fnam is of the form xxxx-yyy
# fname <- gsub("^([^-]+)-.*", "\\1", fnam)
# type <- gsub("^([^-]+)-(.*)", "\\2", fnam) # without "-"
# ## suffix <- gsub("^([^-]+)(-.*)", "\\2", fnam) # with "-"
# }else{
# fname <- fnam
# type = ""
# }
# 2012-11-04 replacing with the code after the comments
#
# namreg <- "^(.+)-([^-]+)$"
# if(grepl(namreg, fnam)){ # fnam is of the form xxxx-yyy (non-empty rhs)
# fname <- gsub(namreg, "\\1", fnam)
# namtype <- gsub(namreg, "\\2", fnam) # without "-"
# ## suffix <- gsub("^([^-]+)(-.*)", "\\2", fnam) # with "-"
# }else{
# fname <- fnam
# namtype = ""
# }
wrknam <- .parse_long_name(fnam)
fname <- wrknam["name"]
namtype <- wrknam["type"]
if(missing(type) || is.null(type))
type <- namtype
else if(namtype != "" && !identical(type, namtype)){
cat("The name and type arguments give conflicting 'type' information.\n")
cat("\tUsing argument 'type'.\n")
}# else 'type' has the value needed.
## 2019-04-26 print a message since otherwise the error is not clear,
## e.g. if the call has 'type = class' (note: no quotes around class)
if(!is.character(type) || length(type) != 1L)
print("!!! if not missing, 'type' must be a character string")
wrk <- try(switch(type,
methods = {
if(is.null(methods) && !is.null(package))
methods <- findMethods(fname, where = asNamespace(package))
if(is.null(methods)) promptMethods(f=fname, filename = NA)
else promptMethods(f=fname, filename = NA, methods=methods)
},
class = promptClass(clName=fname, filename = NA),
package = promptPackageSexpr(fname, filename = NA),
## default
# v tozi variant ima problemi za funktsii ot Rdpack, za koito parviyat
# "if" dava TRUE i sled tova stava greshka. Za funktsii ot drugi paketi
# tova ne e problem, ponezhe za tyach "if"-at dava FALSE, ako sa
# nevidimi.
#
# Tay kato tazi situatsiya mozhe da vaznikne po razlichni nachini,
# promenyam koda. Tryabva oste rabota za sluchaya kogato ima poveche ot
# edno ime...
### if(exists(fname, envir = parent.frame())){
### prompt(object=fname, filename = NA, force.function=TRUE, ...)
### }else{ # todo: needs more work here
### x0 <- do.call(getAnywhere,list(fname))
### browser()
### prompt(object=x0$objs[[1]], filename = NA, force.function=TRUE,
### name = fname, ...)
### }
{
wrk0 <- try(prompt(name=fname, filename = NA, ...), silent=TRUE)
if(inherits(wrk0,"try-error")){
x0 <- do.call(getAnywhere,list(fname))
wrk0 <- prompt(object=x0$objs[[1]], filename=NA, name = fname,
# force.function=TRUE,
...)
}
wrk0 # todo: needs more work here. IN particular, there should be a
# package argument to avoid taking blindly whatever comes up.
} )
, silent = TRUE)
if(inherits(wrk,"try-error"))
res <- wrk
else{
res <- .parse_Rdlines(wrk)
# if successful, res is not inspected here
# since it is generated from the actual definitions.
if(final && type != "package"){ # put dummy title and description
# to avoid errors when installing a package
wrk <- char2Rdpiece("~~ Dummy title ~~", "title")
res <- Rdo_replace_section(res, wrk)
wrk <- char2Rdpiece("~~ Dummy description ~~", "description")
res <- Rdo_replace_section(res, wrk)
# tidy a bit, e.g. to start each section on new line,
# which may not be the case for installed documentation
res <- .Rd_tidy(res) # tidy() could do more; e.g. reorder sections
}
}
res
}
.capture_installed_help <- function(fnam, type = NULL, package = NULL, suffix = NULL){
# this does not work, package seems not evaluated or deparsed
# hlp <- help(paste(fnam, "-methods", sep=""), package=package)
# TODO: the last example in "help()" amy be helpful here.
#
namreg <- "^(.+)-([^-]+)$" # 2012-11-04 new namreg and related
fullname <- if(grepl(namreg, fnam)) # fnam is of the form xxxx-yyy
fnam
else if(!is.null(type) && is.character(type) && type!="")
paste(fnam, "-", type, sep="")
else if(!is.null(suffix))
paste(fnam, suffix, sep="")
else
fnam
hlp <- help(fullname) # todo: more care!
hlpfile <- as.vector(hlp) # removes attributes
# todo: but may be of length > 1, e.g. for "initialize"
# cat("hlpfile has ", length(hlpfile), " element(s):\n")
# print(hlpfile)
if(!is.null(package)){ # try first "/package/" to avoid surprise matches;
# see what happens with package = "methods", without the slashes;
# also, 'package' may be part of the name of another package.
indx <- which( grepl(paste("/", package, "/", sep=""), hlpfile))
if(length(indx)==0) # ... but if nothing matched, try without the slashes.
indx <- which(grepl(package, hlpfile))
hlpfile <- hlpfile[ indx ]
}
if(length(hlpfile) > 1){ # todo: mozhe da se napravi v loop to collect a bunch of sig's
hlpfile <- hlpfile[1]
cat("length(hlpfile)>1, taking the first element.\n")
}
try(utilsdotdotdot.getHelpFile(hlpfile), silent=TRUE)
}
# 'usage' may be an "f_usage" object obtained e.g. by a
# previous call to get_usage() or generated programmatically.
promptUsage <- function (..., usage){ # todo: add formatting options?
if(missing(usage)) get_usage(..., out.format="text")
else as.character(usage)
}
|
