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()

Read our documentation on viewing source code .

Loading