1
###########################################################################/**
2
# @RdocDefault rcode
3
# @alias rcode.RspString
4
# @alias rcode.RspDocument
5
#
6
# @title "Compiles an RSP document and returns the generated source code script"
7
#
8
# \description{
9
#  @get "title".
10
# }
11
#
12
# @synopsis
13
#
14
# \arguments{
15
#   \item{...}{@character strings with RSP markup.}
16
#   \item{file, path}{Alternatively, a file, a URL or a @connection from
17
#      with the strings are read.
18
#      If a file, the \code{path} is prepended to the file, iff given.}
19
#   \item{output}{A @character string or a @connection specifying where
20
#      output should be directed.
21
#      The default is a file with a filename where the file extension(s)
22
#      (typically \code{".*.rsp"}) has been replaced by \code{".R"}
23
#      in the directory given by the \code{workdir} argument.}
24
#   \item{workdir}{The working directory to use after parsing and
25
#      preprocessing.
26
#      If argument \code{output} specifies an absolute pathname,
27
#      then the directory of \code{output} is used, otherwise the
28
#      current directory is used.}
29
#   \item{envir}{The @environment in which the RSP string is
30
#      preprocessed and evaluated.}
31
#   \item{args}{A named @list of arguments assigned to the environment
32
#     in which the RSP string is parsed and evaluated.
33
#     See @see "R.utils::cmdArgs".}
34
#   \item{verbose}{See @see "R.utils::Verbose".}
35
# }
36
#
37
# \value{
38
#   Returns an @see "RspFileProduct" if possible,
39
#   otherwise an @see "RspSourceCode".
40
# }
41
#
42
# @examples "../incl/rcode.Rex"
43
#
44
# @author
45
#
46
# \seealso{
47
#  @see "rcat" and @see "rfile".
48
# }
49
#
50
# @keyword file
51
# @keyword IO
52
# @keyword internal
53
#*/###########################################################################
54
setMethodS3("rcode", "default", function(..., file=NULL, path=NULL, output=NULL, workdir=NULL, envir=parent.frame(), args="*", verbose=FALSE) {
55
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
56
  # Validate arguments
57
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
58
  # Argument 'file' & 'path':
59 1
  if (inherits(file, "connection")) {
60 1
  } else if (is.character(file)) {
61 1
    if (!is.null(path)) {
62 0
      file <- file.path(path, file)
63
    }
64 1
    if (!isUrl(file)) {
65 1
      file <- Arguments$getReadablePathname(file, absolute=TRUE)
66
    }
67
  }
68

69
  # Argument 'workdir':
70 1
  if (is.null(workdir)) {
71 1
    if (isAbsolutePath(output)) {
72 0
      workdir <- getParent(output)
73
    } else {
74 1
      workdir <- "."
75
    }
76
  }
77 1
  workdir <- Arguments$getWritablePath(workdir)
78 1
  if (is.null(workdir)) workdir <- "."
79

80
  # Argument 'output':
81 1
  if (is.null(output)) {
82
    # Default is to return an RSP source code object
83 1
    output <- RspSourceCode()
84

85 1
    if (inherits(file, "connection")) {
86 0
      throw("When argument 'file' is a connection, then 'output' must be specified.")
87 1
    } else if (is.character(file)) {
88
      # Is the input a filename or an URI?
89 1
      if (isUrl(file)) {
90
        # If URI, drop any URI arguments
91 0
        url <- splitUrl(file)
92 0
        filename <- basename(url$path)
93 0
        filename <- Arguments$getReadablePathname(filename, adjust="url", mustExist=FALSE)
94
      } else {
95 1
        filename <- basename(file)
96
      }
97

98 1
      pattern <- "((.*)[.]([^.]+)|([^.]+))[.]([^.]+)$"
99 1
      outputF <- gsub(pattern, "\\1.R", filename, ignore.case=TRUE)
100 1
      withoutGString({
101 1
        output <- Arguments$getWritablePathname(outputF, path=workdir)
102
      })
103 1
      output <- getAbsolutePath(output)
104
      # Don't overwrite the input file
105 1
      if (output == file) {
106 0
        throw("Cannot process RSP file. The inferred argument 'output' is the same as argument 'file' & 'path': ", output, " == ", file)
107
      }
108
    }
109 1
  } else if (inherits(output, "connection")) {
110 1
  } else if (identical(output, "")) {
111 0
    output <- stdout()
112 1
  } else if (inherits(output, "RspSourceCode")) {
113 0
  } else if (is.character(output)) {
114 0
    withoutGString({
115 0
      if (isAbsolutePath(output)) {
116 0
        output <- Arguments$getWritablePathname(output)
117
      } else {
118 0
        output <- Arguments$getWritablePathname(output, path=workdir)
119 0
        output <- getAbsolutePath(output)
120
      }
121
    })
122 0
    if (is.character(file) && (output == file)) {
123 0
      throw("Cannot process RSP file. Argument 'output' specifies the same file as argument 'file' & 'path': ", output, " == ", file)
124
    }
125
  } else {
126 0
    throw("Argument 'output' of unknown type: ", class(output)[1L])
127
  }
128

129
  # Argument 'verbose':
130 1
  verbose <- Arguments$getVerbose(verbose)
131 1
  if (verbose) {
132 1
    pushState(verbose)
133 1
    on.exit(popState(verbose))
134
  }
135

136

137 1
  verbose && enter(verbose, "rcode() for default")
138

139 1
  if (is.null(file)) {
140 0
    s <- RspString(...)
141
  } else {
142 1
    verbose && cat(verbose, "Input file: ", file)
143 1
    s <- .readText(file)
144 1
    s <- RspString(s, source=file, ...)
145 1
    s <- setMetadata(s, name="source", value=file)
146
  }
147 1
  verbose && cat(verbose, "Length of RSP string: ", nchar(s))
148

149 1
  res <- rcode(s, output=output, workdir=workdir, envir=envir, args=args, verbose=verbose)
150

151 1
  verbose && exit(verbose)
152

153 1
  res
154
}) # rcode()
155

156

157
setMethodS3("rcode", "RspString", function(object, output=NULL, workdir=NULL, envir=parent.frame(), args="*", ..., verbose=FALSE) {
158
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
159
  # Validate arguments
160
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
161
  # Argument 'args':
162 1
  args <- cmdArgs(args=args)
163

164
  # Argument 'verbose':
165 1
  verbose <- Arguments$getVerbose(verbose)
166 1
  if (verbose) {
167 1
    pushState(verbose)
168 1
    on.exit(popState(verbose))
169
  }
170

171 1
  verbose && enter(verbose, "rcode() for ", class(object)[1L])
172

173 1
  if (length(args) > 0L) {
174 0
    verbose && enter(verbose, "Assigning RSP arguments to processing environment")
175 0
    verbose && cat(verbose, "Environment: ", getName(envir))
176

177 0
    verbose && cat(verbose, "RSP arguments:")
178 0
    verbose && str(verbose, args)
179

180
    # Assign arguments to the parse/evaluation environment
181 0
    names <- attachLocally(args, envir=envir)
182 0
    if (verbose) {
183 0
      if (length(names) > 0L) {
184 0
        printf(verbose, "Variables assigned: [%d] %s\n", length(names), hpaste(names))
185 0
        member <- NULL; rm(list="member"); # To please R CMD check
186 0
        ll <- subset(ll(envir=envir), member %in% names)
187 0
        print(verbose, ll)
188
      }
189
    }
190 0
    verbose && exit(verbose)
191
  } else {
192 1
    names <- NULL
193
  }
194

195 1
  if (verbose) {
196 1
    enter(verbose, "Parse RSP string to RSP document")
197 1
    cat(verbose, "Parse environment: ", getName(envir))
198 1
    if (length(names) > 0L) {
199 0
      ll <- subset(ll(envir=envir), member %in% names)
200 0
      print(verbose, ll)
201
    }
202
  }
203
  
204 1
  doc <- parseDocument(object, envir=envir, ..., verbose=verbose)
205 1
  verbose && print(verbose, doc)
206 1
  verbose && exit(verbose)
207

208 1
  res <- rcode(doc, output=output, workdir=workdir, envir=envir, args=NULL, ..., verbose=verbose)
209

210 1
  verbose && exit(verbose)
211

212 1
  res
213
}) # rcode()
214

215

216
setMethodS3("rcode", "RspDocument", function(object, output=NULL, workdir=NULL, envir=parent.frame(), ..., verbose=FALSE) {
217
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
218
  # Validate arguments
219
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
220
  # Argument 'workdir':
221 1
  if (is.null(workdir)) {
222 0
    workdir <- "."
223 0
    if (inherits(output, "RspSourceCode")) {
224 0
    } else if (isAbsolutePath(output)) {
225 0
      workdir <- getParent(output)
226
    }
227
  }
228

229
  # Argument 'output':
230 1
  if (!is.null(output)) {
231 1
    if (inherits(output, "connection")) {
232 1
    } else if (inherits(output, "RspSourceCode")) {
233
    } else {
234 1
      withoutGString({
235 1
        output <- Arguments$getWritablePathname(output, path=workdir)
236
      })
237 1
      output <- getAbsolutePath(output)
238
    }
239
  }
240

241
  # Argument 'verbose':
242 1
  verbose <- Arguments$getVerbose(verbose)
243 1
  if (verbose) {
244 1
    pushState(verbose)
245 1
    on.exit(popState(verbose))
246
  }
247

248 1
  verbose && enter(verbose, "rcode() for ", class(object)[1L])
249

250
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
251
  # Coerce
252
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
253 1
  verbose && enter(verbose, "Coerce RSP document to source code")
254 1
  language <- getAttribute(object, "language", default="R")
255 1
  language <- capitalize(tolower(language))
256 1
  className <- sprintf("Rsp%sSourceCodeFactory", language)
257 1
  ns <- getNamespace("R.rsp")
258 1
  clazz <- Class$forName(className, envir=ns)
259 1
  factory <- newInstance(clazz)
260 1
  verbose && cat(verbose, "Language: ", getLanguage(factory))
261 1
  code <- toSourceCode(factory, object, ..., verbose=verbose)
262

263 1
  if (verbose) {
264 1
    enter(verbose, "Generated source code:")
265 1
    codeS <- c(head(code, n=10L), "", "[...]", "", tail(code, n=10L))
266 1
    cat(verbose, codeS)
267 1
    exit(verbose)
268
  }
269

270

271
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
272
  # Return as RspSourceCode, write to file, or ...?
273
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
274 1
  if (inherits(output, "RspSourceCode")) {
275
    # Return as RspSourceCode
276 1
    output <- code
277 1
  } else if (!is.null(output)) {
278
    # Write to file
279 1
    verbose && enter(verbose, "Writing to output")
280 1
    writeLines(code, con=output)
281 1
    verbose && exit(verbose)
282

283 1
    output <- RspFileProduct(output, type=getType(code), metadata=getMetadata(code, local=TRUE), mustExist=FALSE)
284
  } else {
285
    ## Return RspSourceCode
286 0
    output <- code
287
  }
288

289 1
  verbose && exit(verbose)
290

291 1
  output
292
}) # rcode()

Read our documentation on viewing source code .

Loading