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

Read our documentation on viewing source code .

Loading