|
1
|
|
###########################################################################/**
|
|
2
|
|
# @RdocClass RspRSourceCodeFactory
|
|
3
|
|
#
|
|
4
|
|
# @title "The RspRSourceCodeFactory class"
|
|
5
|
|
#
|
|
6
|
|
# \description{
|
|
7
|
|
# @classhierarchy
|
|
8
|
|
#
|
|
9
|
|
# An RspRSourceCodeFactory is an @see "RspSourceCodeFactory" for
|
|
10
|
|
# the R language.
|
|
11
|
|
# }
|
|
12
|
|
#
|
|
13
|
|
# @synopsis
|
|
14
|
|
#
|
|
15
|
|
# \arguments{
|
|
16
|
|
# \item{...}{Not used.}
|
|
17
|
|
# }
|
|
18
|
|
#
|
|
19
|
|
# \section{Fields and Methods}{
|
|
20
|
|
# @allmethods
|
|
21
|
|
# }
|
|
22
|
|
#
|
|
23
|
|
# @author
|
|
24
|
|
#
|
|
25
|
|
# @keyword internal
|
|
26
|
|
#*/###########################################################################
|
|
27
|
|
setConstructorS3("RspRSourceCodeFactory", function(...) {
|
|
28
|
1
|
extend(RspSourceCodeFactory("R"), "RspRSourceCodeFactory")
|
|
29
|
|
})
|
|
30
|
|
|
|
31
|
|
|
|
32
|
|
|
|
33
|
|
setMethodS3("exprToCode", "RspRSourceCodeFactory", function(object, expr, ..., index=NA) {
|
|
34
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
35
|
|
# Local function
|
|
36
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
37
|
1
|
escapeRspText <- function(text) {
|
|
38
|
1
|
stop_if_not(is.character(text), length(text) == 1L)
|
|
39
|
|
|
|
40
|
|
## NOTE: deparse() does not handle UTF-8 strings, e.g.
|
|
41
|
|
## deparse("g\u00e9nome") == "g<U+00E9>nome" :( /HB 2017-01-04
|
|
42
|
|
# text <- deparse(text)
|
|
43
|
|
# text <- substring(text, first=2L, last=nchar(text1)-1L)
|
|
44
|
|
|
|
45
|
|
## BETTER: encodeString() preserves the "\u00e9" format
|
|
46
|
1
|
text <- encodeString(text)
|
|
47
|
|
## WORKAROUND: but we have to undo other escaped other characters
|
|
48
|
1
|
text <- gsub('\"', '\\\"', text, fixed = TRUE)
|
|
49
|
|
|
|
50
|
1
|
stop_if_not(is.character(text), length(text) == 1L)
|
|
51
|
|
|
|
52
|
1
|
text
|
|
53
|
1
|
} # escapeRspText()
|
|
54
|
|
|
|
55
|
|
|
|
56
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
57
|
|
# Validate arguments
|
|
58
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
59
|
|
# Argument 'expr':
|
|
60
|
1
|
reqClasses <- c("RspText", "RspExpression")
|
|
61
|
1
|
if (!inherits(expr, reqClasses)) {
|
|
62
|
0
|
throw("Argument 'expr' must be of class RspText or RspExpression: ", class(expr)[1L])
|
|
63
|
|
}
|
|
64
|
|
|
|
65
|
|
|
|
66
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
67
|
|
# RspText => .rout("<text>")
|
|
68
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
69
|
1
|
if (inherits(expr, "RspText")) {
|
|
70
|
1
|
text <- getContent(expr)
|
|
71
|
|
|
|
72
|
1
|
code <- NULL
|
|
73
|
1
|
while (nchar(text) > 0L) {
|
|
74
|
1
|
textT <- substring(text, first=1L, last=1024L)
|
|
75
|
1
|
textT <- escapeRspText(textT)
|
|
76
|
1
|
codeT <- sprintf(".rout(\"%s\")", textT)
|
|
77
|
1
|
code <- c(code, codeT)
|
|
78
|
1
|
textT <- codeT <- NULL; # Not needed anymore
|
|
79
|
1
|
text <- substring(text, first=1025L)
|
|
80
|
|
}
|
|
81
|
1
|
if (is.null(code)) {
|
|
82
|
1
|
code <- ".rout(\"\")"
|
|
83
|
|
}
|
|
84
|
|
|
|
85
|
1
|
return(code)
|
|
86
|
|
}
|
|
87
|
|
|
|
88
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
89
|
|
# RspCodeChunk => .rout({<expr>})
|
|
90
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
91
|
1
|
if (inherits(expr, "RspCodeChunk")) {
|
|
92
|
1
|
code <- getCode(expr)
|
|
93
|
1
|
code <- trim(code)
|
|
94
|
|
|
|
95
|
|
# Parse and validate code chunk
|
|
96
|
|
# (i) Try without { ... }
|
|
97
|
1
|
codeT <- sprintf("(%s)", code)
|
|
98
|
1
|
rexpr <- tryCatch({
|
|
99
|
1
|
base::parse(text=codeT)
|
|
100
|
1
|
}, error = function(ex) NULL)
|
|
101
|
|
|
|
102
|
|
# (ii) Otherwise retry with { ... }
|
|
103
|
1
|
if (is.null(rexpr)) {
|
|
104
|
1
|
code <- sprintf("{%s}", code)
|
|
105
|
1
|
codeT <- sprintf("(%s)", code)
|
|
106
|
1
|
rexpr <- tryCatch({
|
|
107
|
1
|
base::parse(text=codeT)
|
|
108
|
1
|
}, error = function(ex) {
|
|
109
|
1
|
codeTT <- unlist(strsplit(code, split="", fixed=TRUE))
|
|
110
|
|
# Drop { ... } again
|
|
111
|
1
|
codeTT <- codeTT[-1L]; codeTT <- codeTT[-length(codeTT)]
|
|
112
|
1
|
codeTT <- hpaste(codeTT, collapse="", maxHead=100L, maxTail=30L)
|
|
113
|
1
|
throw(sprintf("RSP code chunk (#%d):\n%s= %s %s\ndoes not contain a complete or valid R expression: %s", index, .rspBracketOpen, codeTT, .rspBracketClose, ex))
|
|
114
|
|
})
|
|
115
|
|
}
|
|
116
|
|
|
|
117
|
1
|
rexpr <- NULL; # Not needed anymore
|
|
118
|
|
|
|
119
|
1
|
echo <- getEcho(expr)
|
|
120
|
1
|
ret <- getInclude(expr)
|
|
121
|
|
|
|
122
|
|
# An <%= ... %> construct?
|
|
123
|
1
|
if (ret && inherits(expr, "RspCodeChunk")) {
|
|
124
|
1
|
rout <- ".rout0"
|
|
125
|
|
} else {
|
|
126
|
0
|
rout <- ".rout"
|
|
127
|
|
}
|
|
128
|
|
|
|
129
|
1
|
if (echo) {
|
|
130
|
0
|
codeE <- sprintf("%s(\"%s\")", rout, escapeRspText(codeT))
|
|
131
|
|
}
|
|
132
|
|
|
|
133
|
1
|
if (echo && !ret) {
|
|
134
|
0
|
code <- c(codeE, code)
|
|
135
|
1
|
} else if (echo && ret) {
|
|
136
|
0
|
codeT <- sprintf(".rtmp <- %s", code)
|
|
137
|
0
|
code <- c(codeE, code, sprintf("%s(.rtmp)", "rm(list=\".rtmp\")", rout))
|
|
138
|
1
|
} else if (!echo && ret) {
|
|
139
|
1
|
code <- sprintf("%s(%s)", rout, code)
|
|
140
|
|
} else {
|
|
141
|
|
}
|
|
142
|
|
|
|
143
|
1
|
return(code)
|
|
144
|
|
}
|
|
145
|
|
|
|
146
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
147
|
|
# RspCode => <code>
|
|
148
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
149
|
1
|
if (inherits(expr, "RspCode")) {
|
|
150
|
1
|
code <- getCode(expr)
|
|
151
|
1
|
echo <- getEcho(expr)
|
|
152
|
1
|
if (echo) {
|
|
153
|
0
|
codeE <- sprintf(".rout(\"%s\")", escapeRspText(code))
|
|
154
|
0
|
code <- c(codeE, code)
|
|
155
|
|
}
|
|
156
|
1
|
return(code)
|
|
157
|
|
}
|
|
158
|
|
|
|
159
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
160
|
|
# RspComment => [void]
|
|
161
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
162
|
0
|
if (inherits(expr, "RspComment")) {
|
|
163
|
0
|
return("")
|
|
164
|
|
}
|
|
165
|
|
|
|
166
|
0
|
throw(sprintf("Unknown class of RSP expression (#%d): %s", index, class(expr)[1L]))
|
|
167
|
|
}, protected=TRUE) # exprToCode()
|
|
168
|
|
|
|
169
|
|
|
|
170
|
|
|
|
171
|
|
setMethodS3("getCompleteCode", "RspRSourceCodeFactory", function(this, object, ...) {
|
|
172
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
173
|
|
# Local functions
|
|
174
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
175
|
1
|
minIndent <- function(...) {
|
|
176
|
1
|
s <- c(...)
|
|
177
|
1
|
s <- gsub('"\n"', '"\r"', s)
|
|
178
|
1
|
s <- unlist(strsplit(s, split="\n", fixed=TRUE), use.names=FALSE)
|
|
179
|
1
|
s <- sapply(s, FUN=function(s) gsub('"\r"', '"\n"', s))
|
|
180
|
1
|
names(s) <- NULL
|
|
181
|
|
|
|
182
|
|
# Nothing todo?
|
|
183
|
0
|
if (length(s) == 0L) return(s)
|
|
184
|
|
|
|
185
|
|
# Clean all-blank lines
|
|
186
|
1
|
s <- gsub("^[ ]*$", "", s)
|
|
187
|
|
# Drop empty lines at the top and the end
|
|
188
|
1
|
while (nchar(s[1L]) == 0L) {
|
|
189
|
1
|
s <- s[-1L]
|
|
190
|
|
}
|
|
191
|
|
|
|
192
|
|
# Nothing todo?
|
|
193
|
0
|
if (length(s) == 0L) return(s)
|
|
194
|
|
|
|
195
|
1
|
while (nchar(s[length(s)]) == 0L) {
|
|
196
|
1
|
s <- s[-length(s)]
|
|
197
|
|
}
|
|
198
|
|
|
|
199
|
|
# Drop duplicated empty lines
|
|
200
|
1
|
idxs <- which(nchar(s) == 0L)
|
|
201
|
1
|
if (length(idxs) > 0L) {
|
|
202
|
1
|
idxs <- idxs[which(diff(idxs) == 1L)]
|
|
203
|
1
|
if (length(idxs) > 0L) {
|
|
204
|
0
|
s <- s[-idxs]
|
|
205
|
|
}
|
|
206
|
|
}
|
|
207
|
|
|
|
208
|
|
# Find minimum indentation of non-blank lines
|
|
209
|
1
|
idxs <- which(nchar(s) > 0L)
|
|
210
|
|
|
|
211
|
|
# Nothing to do?
|
|
212
|
0
|
if (length(idxs) == 0L) return(s)
|
|
213
|
|
|
|
214
|
1
|
prefix <- gsub("^([ ]*).*", "\\1", s[idxs])
|
|
215
|
1
|
min <- min(nchar(prefix))
|
|
216
|
|
|
|
217
|
|
# Nothing to do?
|
|
218
|
0
|
if (min == 0L) return(s)
|
|
219
|
|
|
|
220
|
1
|
pattern <- sprintf("^%s", paste(rep(" ", times=min), collapse=""))
|
|
221
|
1
|
s <- gsub(pattern, "", s)
|
|
222
|
|
|
|
223
|
1
|
s
|
|
224
|
1
|
} # minIndent()
|
|
225
|
|
|
|
226
|
|
|
|
227
|
|
|
|
228
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
229
|
|
# Get the default code header, body and footer
|
|
230
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
231
|
1
|
res <- NextMethod()
|
|
232
|
|
|
|
233
|
|
|
|
234
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
235
|
|
# Update the header
|
|
236
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
237
|
1
|
code <- NULL
|
|
238
|
|
## code <- 'library("R.rsp")'
|
|
239
|
|
|
|
240
|
|
# Add metadata
|
|
241
|
1
|
metadata <- getMetadata(object, local=FALSE)
|
|
242
|
1
|
hdr <- NULL
|
|
243
|
1
|
for (key in names(metadata)) {
|
|
244
|
1
|
value <- metadata[[key]]
|
|
245
|
|
|
|
246
|
|
# Metadata assignments in source code
|
|
247
|
1
|
value <- metadata[[key]]
|
|
248
|
1
|
value <- gsub('"', '\\"', value, fixed=TRUE)
|
|
249
|
1
|
value <- sprintf(' %s = "%s"', key, value)
|
|
250
|
1
|
code <- c(code, value)
|
|
251
|
|
|
|
252
|
|
# Metadata presentation in header comment
|
|
253
|
1
|
value <- metadata[[key]]
|
|
254
|
1
|
value <- gsub("\n", "\\n", value, fixed=TRUE)
|
|
255
|
1
|
value <- gsub("\r", "\\r", value, fixed=TRUE)
|
|
256
|
1
|
hdr <- c(hdr, sprintf(" '%s': '%s'", key, value))
|
|
257
|
|
}
|
|
258
|
|
|
|
259
|
|
# Metadata assignments in source code
|
|
260
|
1
|
code <- unlist(strsplit(paste(code, collapse=",\n"), split="\n", fixed=TRUE), use.names=FALSE)
|
|
261
|
1
|
code <- c('.rmeta <- list(', code, ')')
|
|
262
|
1
|
header0 <- paste(' ', code, sep="")
|
|
263
|
|
|
|
264
|
|
# Metadata presentation in header comment
|
|
265
|
1
|
if (length(hdr) > 0L) {
|
|
266
|
1
|
hdr <- sprintf(" ## %s", hdr)
|
|
267
|
1
|
hdr <- c(" ##", " ## Metadata:", hdr)
|
|
268
|
|
}
|
|
269
|
|
|
|
270
|
|
# Build R source code
|
|
271
|
1
|
res$header <- minIndent('
|
|
272
|
|
## = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
|
|
273
|
|
## This is a self-contained R script generated from an RSP document.
|
|
274
|
|
## It may be evaluated using source() as is.',
|
|
275
|
1
|
hdr,
|
|
276
|
|
' ## = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
|
|
277
|
|
|
|
278
|
|
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
279
|
|
## Local RSP utility functions
|
|
280
|
|
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
281
|
|
## RSP metadata function',
|
|
282
|
1
|
header0,
|
|
283
|
|
'
|
|
284
|
1
|
rmeta <- function(...) {
|
|
285
|
1
|
args <- list(...)
|
|
286
|
1
|
if (length(args) == 0) return(.rmeta)
|
|
287
|
1
|
names <- names(args)
|
|
288
|
1
|
if (length(names) > 0) {
|
|
289
|
1
|
for (name in names) .rmeta[[name]] <<- args[[name]]
|
|
290
|
|
} else {
|
|
291
|
1
|
names <- unlist(args, use.names=FALSE)
|
|
292
|
1
|
if (length(names) == 1) .rmeta[[names]] else .rmeta[names]
|
|
293
|
|
}
|
|
294
|
|
}
|
|
295
|
|
|
|
296
|
|
## Look up \'base\' function once (faster)
|
|
297
|
1
|
if (getRversion() < "2.15.0") {
|
|
298
|
1
|
.base_paste <- base::paste
|
|
299
|
1
|
.base_paste0 <- function(...) .base_paste(..., sep="")
|
|
300
|
|
} else {
|
|
301
|
1
|
.base_paste0 <- base::paste0
|
|
302
|
|
}
|
|
303
|
1
|
.base_cat <- base::cat
|
|
304
|
|
|
|
305
|
|
## RSP output function
|
|
306
|
1
|
.rout <- function(x) .base_cat(.base_paste0(x))
|
|
307
|
|
|
|
308
|
|
## RSP output function for inline RSP constructs
|
|
309
|
1
|
.rout0 <- function(x) .base_cat(rpaste(x))
|
|
310
|
|
|
|
311
|
|
## The output of inline RSP constructs is controlled by
|
|
312
|
|
## generic function rpaste().
|
|
313
|
1
|
rpaste <- function(...) UseMethod("rpaste")
|
|
314
|
|
|
|
315
|
1
|
setInlineRsp <- function(class, fun, envir=parent.frame()) {
|
|
316
|
1
|
name <- sprintf("rpaste.%s", class)
|
|
317
|
1
|
assign(name, fun, envir=envir)
|
|
318
|
|
## FIXME: How to register an S3 method at run-time? /HB 2018-04-06
|
|
319
|
|
## registerS3method("rpaste", class = class, method = name, envir = envir)
|
|
320
|
|
}
|
|
321
|
|
|
|
322
|
|
## The default is to coerce to character and collapse without
|
|
323
|
|
## a separator. It is possible to override the default in an
|
|
324
|
|
## RSP code expression.
|
|
325
|
1
|
setInlineRsp("default", function(x, ...) .base_paste0(x, collapse=""))
|
|
326
|
|
|
|
327
|
|
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
328
|
|
## RSP source code script [BEGIN]
|
|
329
|
|
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
330
|
|
')
|
|
331
|
|
|
|
332
|
1
|
res$footer <- minIndent('
|
|
333
|
|
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
334
|
|
## RSP source code script [END]
|
|
335
|
|
## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
336
|
|
')
|
|
337
|
|
|
|
338
|
1
|
res
|
|
339
|
|
}, protected=TRUE) # getCompleteCode()
|
HenrikBengtsson