HenrikBengtsson / R.rsp
1
###########################################################################/**
2
# @RdocClass RspRSourceCode
3
#
4
# @title "The RspRSourceCode class"
5
#
6
# \description{
7
#  @classhierarchy
8
#
9
#  An RspRSourceCode object is an @see "RspSourceCode" holding R source code.
10
# }
11
#
12
# @synopsis
13
#
14
# \arguments{
15
#   \item{...}{@character strings.}
16
# }
17
#
18
# \section{Fields and Methods}{
19
#  @allmethods
20
# }
21
#
22
# @author
23
#
24
# @keyword internal
25
#*/###########################################################################
26
setConstructorS3("RspRSourceCode", function(...) {
27 1
  extend(RspSourceCode(...), "RspRSourceCode")
28
})
29

30

31

32
#########################################################################/**
33
# @RdocMethod parseCode
34
#
35
# @title "Parses the R code"
36
#
37
# \description{
38
#  @get "title".
39
# }
40
#
41
# @synopsis
42
#
43
# \arguments{
44
#   \item{...}{Not used.}
45
# }
46
#
47
# \value{
48
#  Returns an @expression.
49
# }
50
#
51
# @author
52
#
53
# \seealso{
54
#   @seeclass
55
# }
56
#*/#########################################################################
57
setMethodS3("parseCode", "RspRSourceCode", function(object, ...) {
58
  # Get the source code
59 1
  code <- as.character(object)
60

61
  # Write R code?
62 1
  pathname <- getOption("R.rsp/debug/writeCode", NULL)
63 1
  if (!is.null(pathname)) {
64 0
    if (regexpr("%s", pathname, fixed=TRUE) != -1) {
65 0
      pathname <- sprintf(pathname, digest(code))
66
    }
67 0
    pathname <- Arguments$getWritablePathname(pathname, mustNotExist=FALSE)
68 0
    writeLines(code, con=pathname)
69
##    verbose && cat(verbose, "R source code written to file: ", pathname)
70
  }
71

72
  # Parse R source code
73 1
  expr <- base::parse(text=code)
74

75 1
  expr
76
}, protected=TRUE)
77

78

79

80
#########################################################################/**
81
# @RdocMethod evaluate
82
# @aliasmethod findProcessor
83
#
84
# @title "Parses and evaluates the R code"
85
#
86
# \description{
87
#  @get "title".
88
# }
89
#
90
# @synopsis
91
#
92
# \arguments{
93
#   \item{envir}{The @environment in which the RSP string is evaluated.}
94
#   \item{args}{A named @list of arguments assigned to the environment
95
#     in which the RSP string is parsed and evaluated.
96
#     See @see "R.utils::cmdArgs".}
97
#   \item{output}{A @character string specifying how the RSP output
98
#     should be handled/returned.}
99
#   \item{...}{Not used.}
100
# }
101
#
102
# \value{
103
#  If \code{output="stdout"}, then @NULL is returned and the RSP output
104
#  is sent to the standard output.  This is output is "non-buffered",
105
#  meaning it will be sent to the output as soon as it is generated.
106
#  If \code{output="RspStringProduct"}, then the output is captured
107
#  and returned as an @see "RspStringProduct" with attributes set.
108
# }
109
#
110
# @author
111
#
112
# \seealso{
113
#   @seeclass
114
# }
115
#*/#########################################################################
116
setMethodS3("evaluate", "RspRSourceCode", function(object, envir=parent.frame(), args="*", output=c("RspStringProduct", "stdout"), ..., verbose=FALSE) {
117
  # Argument 'envir':
118 1
  envir <- as.environment(envir)
119

120
  # Argument 'args':
121 1
  args <- cmdArgs(args)
122

123
  # Argument 'output':
124 1
  output <- match.arg(output)
125

126

127
  # Parse R RSP source code
128 1
  expr <- parseCode(object)
129

130
  # Assign arguments to the parse/evaluation environment
131 1
  attachLocally(args, envir=envir)
132

133 1
  if (output == "RspStringProduct") {
134
##    # The default capture.output() uses textConnection()
135
##    # which is much slower than rawConnection().
136
##    res <- capture.output({
137
##      eval(expr, envir=envir)
138
##      # Force a last complete line
139
##      cat("\n")
140
##    })
141
##    res <- paste(res, collapse="\n")
142

143
    # Evaluate R source code and capture output
144 1
    file <- rawConnection(raw(0L), open="w")
145 1
    on.exit({
146 0
      if (!is.null(file)) close(file)
147 1
    }, add=TRUE)
148 1
    capture.output({ eval(expr, envir=envir) }, file=file)
149 1
    res <- rawToChar(rawConnectionValue(file))
150 1
    close(file); file <- NULL
151

152 1
    res <- RspStringProduct(res, attrs=getAttributes(object))
153

154
    # Update metadata?
155 1
    if (exists("rmeta", mode="function", envir=envir)) {
156 1
      rmeta <- get("rmeta", mode="function", envir=envir)
157 1
      res <- setMetadata(res, rmeta())
158
    }
159 1
  } else if (output == "stdout") {
160 1
    eval(expr, envir=envir)
161
    # Force a last complete line
162 1
    cat("\n")
163 1
    res <- NULL
164
  }
165

166 1
  res
167
}, createGeneric=FALSE) # evaluate()
168

169

170
setMethodS3("findProcessor", "RspRSourceCode", function(object, ...) {
171 1
  function(...) {
172 1
    evaluate(...)
173
  }
174
}) # findProcess()
175

176

177

178
setMethodS3("tidy", "RspRSourceCode", function(object, format=c("asis", "tangle", "safetangle", "demo", "unsafedemo"), collapse="\n", ...) {
179
  # Argument 'format':
180 0
  format <- match.arg(format)
181

182
  # Record attributes
183 0
  attrs <- attributes(object)
184

185 0
  code <- object
186

187 0
  if (is.element(format, c("tangle", "safetangle", "demo", "unsafedemo"))) {
188
    # Drop header
189 0
    idx <- grep('## RSP source code script [BEGIN]', code, fixed=TRUE)[1L]
190 0
    if (!is.na(idx)) code <- code[-seq_len(idx+1L)]
191
    # Drop footer
192 0
    idx <- grep('## RSP source code script [END]', code, fixed=TRUE)[1L]
193 0
    if (!is.na(idx)) code <- code[seq_len(idx-2L)]
194
  }
195

196 0
  if (format == "demo") {
197
    # (a) Display a cleaner .rout()
198 0
    hdr <- c('.rout <- function(x)\n  cat(paste(x, sep="", collapse=""))')
199 0
    code <- c(hdr, code)
200 0
  } else if (format == "unsafedemo") {
201
    # NOTE: The generated demo code may not display properly
202
    # (a) Replace .rout(<code chunk>) with cat(<code chunk>)
203 0
    for (rout in c(".rout0", ".rout")) {
204 0
      pattern <- sprintf('^%s', rout)
205 0
      idxs <- grep(pattern, code, fixed=FALSE)
206 0
      if (length(idxs) > 0L) {
207 0
        code[idxs] <- gsub(rout, "cat", code[idxs], fixed=TRUE)
208
      }
209
    }
210 0
  } else if (is.element(format, c("tangle", "safetangle"))) {
211
    # (a) Drop all .rout("...")
212 0
    idxs <- grep('^.rout[(]"', code, fixed=FALSE)
213 0
    if (length(idxs) > 0L) {
214 0
      code <- code[-idxs]
215
    }
216

217 0
    if (format == "tangle") {
218
      # (b) Drop all .rout0(...)
219 0
      idxs <- grep('^.rout0[(]', code, fixed=FALSE)
220 0
      if (length(idxs) > 0L) {
221 0
        code <- code[-idxs]
222
      }
223
    }
224

225
    # (c) Replace .rout(<code chunk>) with (<code chunk>).
226 0
    for (rout in c(".rout0", ".rout")) {
227 0
      pattern <- sprintf('^%s[(]', rout)
228 0
      idxs <- grep(pattern, code, fixed=FALSE)
229 0
      if (length(idxs) > 0L) {
230 0
        first <- nchar(rout) + 2L
231 0
        code[idxs] <- substring(code[idxs], first=first, last=nchar(code[idxs])-1L)
232
      }
233
    }
234
  } # if (format ...)
235

236
  # Collapse?
237 0
  if (!is.null(collapse)) {
238 0
    code <- paste(code, collapse=collapse)
239
  }
240

241
  # Recreate RSP source code object, i.e. restore attributes (if lost)
242 0
  object <- code
243 0
  attributes(object) <- attrs
244

245 0
  object
246
})
247

248

249
setMethodS3("tangle", "RspRSourceCode", function(code, format=c("safetangle", "tangle"), ...) {
250 0
  format <- match.arg(format)
251 0
  tidy(code, format=format)
252
})

Read our documentation on viewing source code .

Loading