|
1
|
|
###########################################################################/**
|
|
2
|
|
# @RdocClass RspFileProduct
|
|
3
|
|
#
|
|
4
|
|
# @title "The RspFileProduct class"
|
|
5
|
|
#
|
|
6
|
|
# \description{
|
|
7
|
|
# @classhierarchy
|
|
8
|
|
#
|
|
9
|
|
# An RspFileProduct is an @see RspProduct that represents an
|
|
10
|
|
# RSP product in form of a file, e.g. LaTeX, Sweave and knitr documents.
|
|
11
|
|
# }
|
|
12
|
|
#
|
|
13
|
|
# @synopsis
|
|
14
|
|
#
|
|
15
|
|
# \arguments{
|
|
16
|
|
# \item{pathname}{An existing file.}
|
|
17
|
|
# \item{...}{Additional arguments passed to @see "RspProduct".}
|
|
18
|
|
# \item{mustExist}{If @TRUE, it is asserted that the file exists.}
|
|
19
|
|
# }
|
|
20
|
|
#
|
|
21
|
|
# \section{Fields and Methods}{
|
|
22
|
|
# @allmethods
|
|
23
|
|
# }
|
|
24
|
|
#
|
|
25
|
|
# @author
|
|
26
|
|
#
|
|
27
|
|
# @keyword internal
|
|
28
|
|
#*/###########################################################################
|
|
29
|
|
setConstructorS3("RspFileProduct", function(pathname=NA, ..., mustExist=TRUE) {
|
|
30
|
|
# Argument 'pathname':
|
|
31
|
1
|
if (!is.null(pathname) && !is.na(pathname)) {
|
|
32
|
1
|
if (!isUrl(pathname)) {
|
|
33
|
1
|
withoutGString({
|
|
34
|
1
|
pathname <- Arguments$getReadablePathname(pathname, mustExist=mustExist)
|
|
35
|
|
})
|
|
36
|
|
}
|
|
37
|
|
}
|
|
38
|
|
|
|
39
|
1
|
extend(RspProduct(pathname, ...), "RspFileProduct")
|
|
40
|
|
})
|
|
41
|
|
|
|
42
|
|
|
|
43
|
|
setMethodS3("print", "RspFileProduct", function(x, ...) {
|
|
44
|
1
|
s <- sprintf("%s:", class(x)[1L])
|
|
45
|
|
|
|
46
|
1
|
s <- c(s, sprintf("Pathname: %s", x))
|
|
47
|
|
|
|
48
|
|
# File size
|
|
49
|
1
|
fileSize <- getFileSize(x, "units")
|
|
50
|
1
|
if (!is.na(fileSize)) {
|
|
51
|
1
|
fileSizeB <- sprintf("%.0f bytes", getFileSize(x, "numeric"))
|
|
52
|
1
|
if (fileSizeB != fileSize) {
|
|
53
|
1
|
fileSize <- sprintf("%s (%s)", fileSize, fileSizeB)
|
|
54
|
|
}
|
|
55
|
|
}
|
|
56
|
1
|
s <- c(s, sprintf("File size: %s", fileSize))
|
|
57
|
|
|
|
58
|
1
|
s <- c(s, sprintf("Content type: %s", getType(x)))
|
|
59
|
|
|
|
60
|
1
|
md <- getMetadata(x, local=FALSE)
|
|
61
|
1
|
for (key in names(md)) {
|
|
62
|
1
|
s <- c(s, sprintf("Metadata '%s': '%s'", key, md[[key]]))
|
|
63
|
|
}
|
|
64
|
|
|
|
65
|
1
|
s <- c(s, sprintf("Has processor: %s", hasProcessor(x)))
|
|
66
|
|
|
|
67
|
1
|
s <- paste(s, collapse="\n")
|
|
68
|
1
|
cat(s, "\n", sep="")
|
|
69
|
|
}, protected=TRUE)
|
|
70
|
|
|
|
71
|
|
|
|
72
|
|
|
|
73
|
|
setMethodS3("view", "RspFileProduct", function(object, ...) {
|
|
74
|
|
# WORKAROUND: browseURL('foo/bar.html', browser=NULL), which in turn
|
|
75
|
|
# calls shell.exec('foo/bar.html'), does not work on Windows, because
|
|
76
|
|
# the OS expects backslashes. [Should shell.exec() convert to
|
|
77
|
|
# backslashes?] By temporarily setting the working directory to that
|
|
78
|
|
# of the file, view() for RspFileProduct works around this issue.
|
|
79
|
0
|
if (isFile(object)) {
|
|
80
|
0
|
path <- dirname(object)
|
|
81
|
0
|
pathname <- basename(object)
|
|
82
|
0
|
opwd <- getwd()
|
|
83
|
0
|
on.exit(setwd(opwd))
|
|
84
|
0
|
setwd(path)
|
|
85
|
|
} else {
|
|
86
|
0
|
pathname <- object
|
|
87
|
|
}
|
|
88
|
0
|
browseURL(pathname, ...)
|
|
89
|
0
|
invisible(object)
|
|
90
|
|
}, proctected=TRUE)
|
|
91
|
|
|
|
92
|
|
|
|
93
|
|
|
|
94
|
|
setMethodS3("getType", "RspFileProduct", function(object, default=NA_character_, as=c("text", "IMT"), ...) {
|
|
95
|
1
|
as <- match.arg(as)
|
|
96
|
1
|
res <- NextMethod("getType", default=NA_character_)
|
|
97
|
|
|
|
98
|
1
|
if (is.na(res)) {
|
|
99
|
|
# Infer type from the filename extension?
|
|
100
|
1
|
if (isFile(object) || isUrl(object)) {
|
|
101
|
1
|
res <- extensionToIMT(object)
|
|
102
|
|
}
|
|
103
|
|
}
|
|
104
|
|
|
|
105
|
|
# Fall back to a default?
|
|
106
|
1
|
if (is.na(res)) {
|
|
107
|
1
|
default <- as.character(default)
|
|
108
|
1
|
res <- default
|
|
109
|
|
}
|
|
110
|
|
|
|
111
|
1
|
if (as == "IMT" && !is.na(res)) {
|
|
112
|
0
|
res <- parseInternetMediaType(res)
|
|
113
|
|
}
|
|
114
|
|
|
|
115
|
1
|
res
|
|
116
|
|
}, protected=TRUE)
|
|
117
|
|
|
|
118
|
|
|
|
119
|
|
setMethodS3("getFileSize", "RspFileProduct", function(object, what=c("numeric", "units"), sep="", ...) {
|
|
120
|
|
# Argument 'what':
|
|
121
|
1
|
what <- match.arg(what)
|
|
122
|
|
|
|
123
|
1
|
pathname <- object
|
|
124
|
1
|
if (is.null(pathname) && isUrl(pathname)) {
|
|
125
|
0
|
fileSize <- NA_real_
|
|
126
|
|
} else {
|
|
127
|
1
|
fileSize <- file.info2(pathname)$size
|
|
128
|
|
}
|
|
129
|
|
|
|
130
|
1
|
if (what == "numeric")
|
|
131
|
1
|
return(fileSize)
|
|
132
|
|
|
|
133
|
1
|
if (is.na(fileSize))
|
|
134
|
1
|
return(fileSize)
|
|
135
|
|
|
|
136
|
1
|
units <- c("bytes", "kB", "MB", "GB", "TB")
|
|
137
|
1
|
scale <- 1
|
|
138
|
1
|
for (kk in seq_along(units)) {
|
|
139
|
1
|
unit <- units[kk]
|
|
140
|
1
|
if (fileSize < 1000)
|
|
141
|
1
|
break
|
|
142
|
1
|
fileSize <- fileSize/1024
|
|
143
|
|
}
|
|
144
|
1
|
fileSize <- sprintf("%.2f %s%s", fileSize, sep, unit)
|
|
145
|
1
|
fileSize <- gsub(".00 bytes", " bytes", fileSize, fixed=TRUE)
|
|
146
|
|
|
|
147
|
1
|
fileSize
|
|
148
|
|
})
|
|
149
|
|
|
|
150
|
|
|
|
151
|
|
|
|
152
|
|
setMethodS3("findProcessor", "RspFileProduct", function(object, ..., verbose=FALSE) {
|
|
153
|
1
|
isFALSE <- function(x) {
|
|
154
|
0
|
if (is.character(x)) return(toupper(x) == "FALSE")
|
|
155
|
1
|
if (is.logical(x) && !x) return(TRUE)
|
|
156
|
1
|
FALSE
|
|
157
|
|
}
|
|
158
|
|
|
|
159
|
1
|
localCompileLaTeX <- function(..., texinputs=NULL) {
|
|
160
|
1
|
if (!is.null(source)) {
|
|
161
|
1
|
path <- dirname(source)
|
|
162
|
1
|
pathA <- getAbsolutePath(path)
|
|
163
|
1
|
texinputs <- c(texinputs, pathA)
|
|
164
|
|
}
|
|
165
|
1
|
compileLaTeX(..., texinputs=texinputs)
|
|
166
|
1
|
} # localCompileLaTeX()
|
|
167
|
|
|
|
168
|
|
|
|
169
|
1
|
localCompressPDF <- function(pathname, ..., verbose=FALSE) {
|
|
170
|
|
# Argument 'verbose':
|
|
171
|
1
|
verbose <- Arguments$getVerbose(verbose)
|
|
172
|
1
|
if (verbose) {
|
|
173
|
1
|
pushState(verbose)
|
|
174
|
1
|
on.exit(popState(verbose))
|
|
175
|
|
}
|
|
176
|
|
|
|
177
|
|
## Disabling further postprocessing after this,
|
|
178
|
|
## which avoids recursive loop.
|
|
179
|
1
|
metadata <- attr(pathname, "metadata")
|
|
180
|
1
|
metadata$postprocess <- FALSE
|
|
181
|
1
|
attr(pathname, "metadata") <- metadata
|
|
182
|
|
|
|
183
|
|
## Get compression level
|
|
184
|
1
|
compression <- metadata$compression
|
|
185
|
|
|
|
186
|
1
|
verbose && enter(verbose, "Trying to compress PDF")
|
|
187
|
1
|
verbose && cat(verbose, "Compression: ", compression)
|
|
188
|
|
|
|
189
|
1
|
pathT <- tempfile(pattern=".dir", tmpdir=".")
|
|
190
|
1
|
on.exit(removeDirectory(pathT, recursive=TRUE), add=TRUE)
|
|
191
|
|
|
|
192
|
|
## ROBUSTNESS: If compression fails for one reason or the
|
|
193
|
|
## other, fall back to keep the non-compressed version.
|
|
194
|
1
|
tryCatch({
|
|
195
|
1
|
verbose && enter(verbose, "R.utils::compressPDF()...")
|
|
196
|
1
|
suppressWarnings({
|
|
197
|
1
|
pathnameZ <- compressPDF(pathname, outPath=pathT,
|
|
198
|
1
|
compression=compression)
|
|
199
|
|
})
|
|
200
|
1
|
verbose && exit(verbose)
|
|
201
|
|
|
|
202
|
1
|
size <- file.info(pathname)$size
|
|
203
|
1
|
sizeZ <- file.info(pathnameZ)$size
|
|
204
|
1
|
if (!identical(sizeZ, size)) {
|
|
205
|
0
|
renameFile(pathnameZ, pathname, overwrite=TRUE)
|
|
206
|
|
}
|
|
207
|
1
|
}, error = function(ex) {
|
|
208
|
0
|
msg <- sprintf("Compression of '%s' using '%s' failed. Keeping the original PDF file. Reason was: %s", pathname, compression, ex$message)
|
|
209
|
0
|
verbose && cat(verbose, msg)
|
|
210
|
0
|
warning(msg)
|
|
211
|
|
})
|
|
212
|
|
|
|
213
|
1
|
verbose && exit(verbose)
|
|
214
|
|
|
|
215
|
1
|
pathname
|
|
216
|
1
|
} # localCompressPDF()
|
|
217
|
|
|
|
218
|
|
|
|
219
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
220
|
|
# Validate arguments
|
|
221
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
|
222
|
|
# Argument 'verbose':
|
|
223
|
1
|
verbose <- Arguments$getVerbose(verbose)
|
|
224
|
1
|
if (verbose) {
|
|
225
|
1
|
pushState(verbose)
|
|
226
|
1
|
on.exit(popState(verbose))
|
|
227
|
|
}
|
|
228
|
|
|
|
229
|
|
|
|
230
|
1
|
verbose && enter(verbose, "Locating document-type specific processor")
|
|
231
|
1
|
type <- getType(object)
|
|
232
|
1
|
verbose && cat(verbose, "RSP product content type: ", type)
|
|
233
|
|
|
|
234
|
|
# Nothing to do?
|
|
235
|
1
|
if (is.na(type)) {
|
|
236
|
1
|
verbose && cat(verbose, "Processor found: <none>")
|
|
237
|
1
|
verbose && exit(verbose)
|
|
238
|
1
|
return(NULL)
|
|
239
|
|
}
|
|
240
|
1
|
type <- parseInternetMediaType(type)$contentType
|
|
241
|
|
|
|
242
|
|
|
|
243
|
|
# Nothing to do?
|
|
244
|
1
|
postprocess <- getMetadata(object, "postprocess", local=TRUE)
|
|
245
|
1
|
if (isFALSE(postprocess)) {
|
|
246
|
1
|
verbose && cat(verbose, "Processing disabled: metadata variable 'postprocess' is FALSE")
|
|
247
|
1
|
verbose && exit(verbose)
|
|
248
|
1
|
return(NULL)
|
|
249
|
|
}
|
|
250
|
|
|
|
251
|
|
|
|
252
|
1
|
source <- getMetadata(object, "source", local=TRUE)
|
|
253
|
1
|
if (is.null(source)) {
|
|
254
|
1
|
verbose && cat(verbose, "Source document: <unknown>")
|
|
255
|
|
} else {
|
|
256
|
1
|
verbose && cat(verbose, "Source document: ", sQuote(source))
|
|
257
|
|
}
|
|
258
|
|
|
|
259
|
|
|
|
260
|
|
|
|
261
|
|
# Find a down-stream compiler/processor:
|
|
262
|
1
|
fcn <- switch(type,
|
|
263
|
|
# RSP documents:
|
|
264
|
|
# *<ext>.rsp => *.<ext>
|
|
265
|
1
|
"application/x-rsp" = function(...) { compileRsp(..., postprocess=FALSE) },
|
|
266
|
|
|
|
267
|
|
# LaTeX documents:
|
|
268
|
|
# *.tex => ... => *.pdf
|
|
269
|
1
|
"application/x-tex" = localCompileLaTeX,
|
|
270
|
1
|
"application/x-latex" = localCompileLaTeX,
|
|
271
|
|
|
|
272
|
|
## PDF documents:
|
|
273
|
|
# *.pdf => ... => *.pdf
|
|
274
|
1
|
"application/pdf" = localCompressPDF,
|
|
275
|
|
|
|
276
|
|
# Markdown documents:
|
|
277
|
|
# *.md => *.html
|
|
278
|
1
|
"application/x-markdown" = compileMarkdown,
|
|
279
|
|
|
|
280
|
|
# Markdown documents:
|
|
281
|
|
# *.txt => *.html, ...
|
|
282
|
0
|
"application/x-asciidoc" = function(...) { compileAsciiDoc(..., postprocess=FALSE) },
|
|
283
|
|
|
|
284
|
|
# Sweave Rnw documents:
|
|
285
|
|
# *.Rnw => *.tex
|
|
286
|
0
|
"application/x-sweave" = function(...) { compileSweave(..., postprocess=FALSE) },
|
|
287
|
|
|
|
288
|
|
# Knitr Rnw documents:
|
|
289
|
|
# *.Rnw => *.tex
|
|
290
|
0
|
"application/x-knitr" = function(...) { compileKnitr(..., postprocess=FALSE) },
|
|
291
|
|
|
|
292
|
|
# Knitr Rmd documents:
|
|
293
|
|
# *.Rmd => *.html
|
|
294
|
0
|
"application/x-rmd" = function(...) { compileKnitr(..., postprocess=FALSE) },
|
|
295
|
|
# Knitr Rhtml documents:
|
|
296
|
|
# *.Rhtml => *.html
|
|
297
|
0
|
"application/x-rhtml" = function(...) { compileKnitr(..., postprocess=FALSE) },
|
|
298
|
|
|
|
299
|
|
# Knitr Rtex documents:
|
|
300
|
|
# *.Rtex => *.tex
|
|
301
|
0
|
"application/x-rtex" = function(...) { compileKnitr(..., postprocess=FALSE) },
|
|
302
|
|
|
|
303
|
|
# Knitr Rrst documents:
|
|
304
|
|
# *.Rrst => *.rst
|
|
305
|
0
|
"application/x-rrst" = function(...) { compileKnitr(..., postprocess=FALSE) },
|
|
306
|
|
|
|
307
|
|
# AsciiDoc Rnw documents:
|
|
308
|
|
# *.Rnw => *.txt
|
|
309
|
1
|
"application/x-asciidoc-noweb" = function(...) { compileAsciiDocNoweb(..., postprocess=FALSE) },
|
|
310
|
|
|
|
311
|
|
# Sweave or Knitr Rnw documents:
|
|
312
|
|
# *.Rnw => *.tex
|
|
313
|
1
|
"application/x-rnw" = function(...) { compileRnw(..., postprocess=FALSE) }
|
|
314
|
|
)
|
|
315
|
|
|
|
316
|
1
|
if (is.null(fcn)) {
|
|
317
|
1
|
verbose && cat(verbose, "Processor found: <none>")
|
|
318
|
|
} else {
|
|
319
|
|
# Get the metadata attributes
|
|
320
|
1
|
metadata <- getMetadata(object, local=TRUE)
|
|
321
|
|
|
|
322
|
|
# Make sure the processor returns an RspFileProduct
|
|
323
|
1
|
fcnT <- fcn
|
|
324
|
1
|
processor <- function(...) {
|
|
325
|
1
|
do.call(fcnT, args=c(list(...), list(metadata=metadata)))
|
|
326
|
|
}
|
|
327
|
|
|
|
328
|
1
|
fcn <- function(pathname, ...) {
|
|
329
|
|
# Arguments 'pathname':
|
|
330
|
1
|
if (!isUrl(pathname)) {
|
|
331
|
1
|
withoutGString({
|
|
332
|
1
|
pathnameT <- Arguments$getReadablePathname(pathname)
|
|
333
|
1
|
pathname[1] <- pathnameT; ## Preserve class and attributes etc.
|
|
334
|
|
})
|
|
335
|
|
}
|
|
336
|
|
|
|
337
|
|
# NOTE: It is not sure that the processor supports URLs
|
|
338
|
1
|
pathnameR <- processor(pathname, ...)
|
|
339
|
|
|
|
340
|
|
## Check if further postprocessoring should be disabled
|
|
341
|
1
|
metadataR <- getMetadata(pathnameR)
|
|
342
|
1
|
postprocessR <- getMetadata(pathnameR, "postprocess", local=TRUE)
|
|
343
|
1
|
if (isFALSE(postprocessR)) metadata$postprocess <- FALSE
|
|
344
|
|
|
|
345
|
|
# Always return the relative path
|
|
346
|
1
|
pathnameR <- getAbsolutePath(pathnameR)
|
|
347
|
1
|
res <- RspFileProduct(pathnameR, attrs=list(metadata=metadata), mustExist=FALSE)
|
|
348
|
1
|
res <- setMetadata(res, name="source", value=pathname)
|
|
349
|
|
|
|
350
|
1
|
res
|
|
351
|
1
|
} # fcn()
|
|
352
|
1
|
verbose && cat(verbose, "Processor found: ", type)
|
|
353
|
|
}
|
|
354
|
|
|
|
355
|
1
|
verbose && exit(verbose)
|
|
356
|
|
|
|
357
|
1
|
fcn
|
|
358
|
|
}, protected=TRUE) # findProcessor()
|
HenrikBengtsson