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 2
  extend(RspSourceCodeFactory("R"), "RspRSourceCodeFactory")
29
})
30

31

32

33
setMethodS3("exprToCode", "RspRSourceCodeFactory", function(object, expr, ..., index=NA) {
34
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35
  # Local function
36
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37 2
  escapeRspText <- function(text) {
38 2
    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 2
    text <- encodeString(text)
47
    ## WORKAROUND: but we have to undo other escaped other characters
48 2
    text <- gsub('\"', '\\\"', text, fixed = TRUE)
49
    
50 2
    stop_if_not(is.character(text), length(text) == 1L)
51

52 2
    text
53 2
  } # escapeRspText()
54

55

56
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
57
  # Validate arguments
58
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
59
  # Argument 'expr':
60 2
  reqClasses <- c("RspText", "RspExpression")
61 2
  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 2
  if (inherits(expr, "RspText")) {
70 2
    text <- getContent(expr)
71

72 2
    code <- NULL
73 2
    while (nchar(text) > 0L) {
74 2
      textT <- substring(text, first=1L, last=1024L)
75 2
      textT <- escapeRspText(textT)
76 2
      codeT <- sprintf(".rout(\"%s\")", textT)
77 2
      code <- c(code, codeT)
78 2
      textT <- codeT <- NULL; # Not needed anymore
79 2
      text <- substring(text, first=1025L)
80
    }
81 2
    if (is.null(code)) {
82 2
      code <- ".rout(\"\")"
83
    }
84

85 2
    return(code)
86
  }
87

88
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
89
  # RspCodeChunk => .rout({<expr>})
90
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
91 2
  if (inherits(expr, "RspCodeChunk")) {
92 2
    code <- getCode(expr)
93 2
    code <- trim(code)
94

95
    # Parse and validate code chunk
96
    # (i) Try without { ... }
97 2
    codeT <- sprintf("(%s)", code)
98 2
    rexpr <- tryCatch({
99 2
      base::parse(text=codeT)
100 2
    }, error = function(ex) NULL)
101

102
    # (ii) Otherwise retry with { ... }
103 2
    if (is.null(rexpr)) {
104 2
      code <- sprintf("{%s}", code)
105 2
      codeT <- sprintf("(%s)", code)
106 2
      rexpr <- tryCatch({
107 2
        base::parse(text=codeT)
108 2
      }, error = function(ex) {
109 2
        codeTT <- unlist(strsplit(code, split="", fixed=TRUE))
110
        # Drop { ... } again
111 2
        codeTT <- codeTT[-1L]; codeTT <- codeTT[-length(codeTT)]
112 2
        codeTT <- hpaste(codeTT, collapse="", maxHead=100L, maxTail=30L)
113 2
        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 2
    rexpr <- NULL; # Not needed anymore
118

119 2
    echo <- getEcho(expr)
120 2
    ret <- getInclude(expr)
121

122
    # An <%= ... %> construct?
123 2
    if (ret && inherits(expr, "RspCodeChunk")) {
124 2
      rout <- ".rout0"
125
    } else {
126 0
      rout <- ".rout"
127
    }
128

129 2
    if (echo) {
130 0
      codeE <- sprintf("%s(\"%s\")", rout, escapeRspText(codeT))
131
    }
132

133 2
    if (echo && !ret) {
134 0
      code <- c(codeE, code)
135 2
    } 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 2
    } else if (!echo && ret) {
139 2
      code <- sprintf("%s(%s)", rout, code)
140
    } else {
141
    }
142

143 2
    return(code)
144
  }
145

146
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
147
  # RspCode => <code>
148
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
149 2
  if (inherits(expr, "RspCode")) {
150 2
    code <- getCode(expr)
151 2
    echo <- getEcho(expr)
152 2
    if (echo) {
153 0
      codeE <- sprintf(".rout(\"%s\")", escapeRspText(code))
154 0
      code <- c(codeE, code)
155
    }
156 2
    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 2
  minIndent <- function(...) {
176 2
    s <- c(...)
177 2
    s <- gsub('"\n"', '"\r"', s)
178 2
    s <- unlist(strsplit(s, split="\n", fixed=TRUE), use.names=FALSE)
179 2
    s <- sapply(s, FUN=function(s) gsub('"\r"', '"\n"', s))
180 2
    names(s) <- NULL
181

182
    # Nothing todo?
183 0
    if (length(s) == 0L) return(s)
184

185
    # Clean all-blank lines
186 2
    s <- gsub("^[ ]*$", "", s)
187
    # Drop empty lines at the top and the end
188 2
    while (nchar(s[1L]) == 0L) {
189 2
      s <- s[-1L]
190
    }
191

192
    # Nothing todo?
193 0
    if (length(s) == 0L) return(s)
194

195 2
    while (nchar(s[length(s)]) == 0L) {
196 2
      s <- s[-length(s)]
197
    }
198

199
    # Drop duplicated empty lines
200 2
    idxs <- which(nchar(s) == 0L)
201 2
    if (length(idxs) > 0L) {
202 2
      idxs <- idxs[which(diff(idxs) == 1L)]
203 2
      if (length(idxs) > 0L) {
204 0
        s <- s[-idxs]
205
      }
206
    }
207

208
    # Find minimum indentation of non-blank lines
209 2
    idxs <- which(nchar(s) > 0L)
210

211
    # Nothing to do?
212 0
    if (length(idxs) == 0L) return(s)
213

214 2
    prefix <- gsub("^([ ]*).*", "\\1", s[idxs])
215 2
    min <- min(nchar(prefix))
216

217
    # Nothing to do?
218 0
    if (min == 0L) return(s)
219

220 2
    pattern <- sprintf("^%s", paste(rep(" ", times=min), collapse=""))
221 2
    s <- gsub(pattern, "", s)
222

223 2
    s
224 2
  } # minIndent()
225

226

227

228
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
229
  # Get the default code header, body and footer
230
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
231 2
  res <- NextMethod()
232

233

234
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
235
  # Update the header
236
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
237 2
  code <- NULL
238
##  code <- 'library("R.rsp")'
239

240
  # Add metadata
241 2
  metadata <- getMetadata(object, local=FALSE)
242 2
  hdr <- NULL
243 2
  for (key in names(metadata)) {
244 2
     value <- metadata[[key]]
245

246
     # Metadata assignments in source code
247 2
     value <- metadata[[key]]
248 2
     value <- gsub('"', '\\"', value, fixed=TRUE)
249 2
     value <- sprintf('  %s = "%s"', key, value)
250 2
     code <- c(code, value)
251

252
     # Metadata presentation in header comment
253 2
     value <- metadata[[key]]
254 2
     value <- gsub("\n", "\\n", value, fixed=TRUE)
255 2
     value <- gsub("\r", "\\r", value, fixed=TRUE)
256 2
     hdr <- c(hdr, sprintf("  '%s': '%s'", key, value))
257
  }
258

259
  # Metadata assignments in source code
260 2
  code <- unlist(strsplit(paste(code, collapse=",\n"), split="\n", fixed=TRUE), use.names=FALSE)
261 2
  code <- c('.rmeta <- list(', code, ')')
262 2
  header0 <- paste('    ', code, sep="")
263

264
  # Metadata presentation in header comment
265 2
  if (length(hdr) > 0L) {
266 2
    hdr <- sprintf("    ## %s", hdr)
267 2
    hdr <- c("    ##", "    ## Metadata:", hdr)
268
  }
269

270
  # Build R source code
271 2
  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 2
    hdr,
276
'    ## = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
277

278
    ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
279
    ## Local RSP utility functions
280
    ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
281
    ## RSP metadata function',
282 2
    header0,
283
    '
284 2
    rmeta <- function(...) {
285 2
      args <- list(...)
286 2
      if (length(args) == 0) return(.rmeta)
287 2
      names <- names(args)
288 2
      if (length(names) > 0) {
289 2
        for (name in names) .rmeta[[name]] <<- args[[name]]
290
      } else {
291 2
        names <- unlist(args, use.names=FALSE)
292 2
        if (length(names) == 1) .rmeta[[names]] else .rmeta[names]
293
      }
294
    }
295

296
    ## Look up \'base\' function once (faster)
297 2
    if (getRversion() < "2.15.0") {
298 2
      .base_paste <- base::paste
299 2
      .base_paste0 <- function(...) .base_paste(..., sep="")
300
    } else {
301 2
      .base_paste0 <- base::paste0
302
    }
303 2
    .base_cat <- base::cat
304

305
    ## RSP output function
306 2
    .rout <- function(x) .base_cat(.base_paste0(x))
307

308
    ## RSP output function for inline RSP constructs
309 2
    .rout0 <- function(x) .base_cat(rpaste(x))
310

311
    ## The output of inline RSP constructs is controlled by
312
    ## generic function rpaste().
313 2
    rpaste <- function(...) UseMethod("rpaste")
314

315 2
    setInlineRsp <- function(class, fun, envir=parent.frame()) {
316 2
      name <- sprintf("rpaste.%s", class)
317 2
      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 2
    setInlineRsp("default", function(x, ...) .base_paste0(x, collapse=""))
326

327
    ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
328
    ## RSP source code script [BEGIN]
329
    ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
330
  ')
331

332 2
  res$footer <- minIndent('
333
    ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
334
    ## RSP source code script [END]
335
    ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
336
  ')
337

338 2
  res
339
}, protected=TRUE) # getCompleteCode()

Read our documentation on viewing source code .

Loading