RspFileProduct.R at c4b1d02 ⋅ HenrikBengtsson/R.rsp

###########################################################################/**
# @RdocClass RspFileProduct
#
# @title "The RspFileProduct class"
#
# \description{
#  @classhierarchy
#
#  An RspFileProduct is an @see RspProduct that represents an
#  RSP product in form of a file, e.g. LaTeX, Sweave and knitr documents.
# }
#
# @synopsis
#
# \arguments{
#   \item{pathname}{An existing file.}
#   \item{...}{Additional arguments passed to @see "RspProduct".}
#   \item{mustExist}{If @TRUE, it is asserted that the file exists.}
# }
#
# \section{Fields and Methods}{
#  @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspFileProduct", function(pathname=NA, ..., mustExist=TRUE) {
  # Argument 'pathname':
  if (!is.null(pathname) && !is.na(pathname)) {
    if (!isUrl(pathname)) {
      withoutGString({
        pathname <- Arguments$getReadablePathname(pathname, mustExist=mustExist)
      })
    }
  }

  extend(RspProduct(pathname, ...), "RspFileProduct")
})


setMethodS3("print", "RspFileProduct", function(x, ...) {
  s <- sprintf("%s:", class(x)[1L])

  s <- c(s, sprintf("Pathname: %s", x))

  # File size
  fileSize <- getFileSize(x, "units")
  if (!is.na(fileSize)) {
    fileSizeB <- sprintf("%.0f bytes", getFileSize(x, "numeric"))
    if (fileSizeB != fileSize) {
      fileSize <- sprintf("%s (%s)", fileSize, fileSizeB)
    }
  }
  s <- c(s, sprintf("File size: %s", fileSize))

  s <- c(s, sprintf("Content type: %s", getType(x)))

  md <- getMetadata(x, local=FALSE)
  for (key in names(md)) {
    s <- c(s, sprintf("Metadata '%s': '%s'", key, md[[key]]))
  }

  s <- c(s, sprintf("Has processor: %s", hasProcessor(x)))

  s <- paste(s, collapse="\n")
  cat(s, "\n", sep="")
}, protected=TRUE)



setMethodS3("view", "RspFileProduct", function(object, ...) {
  # WORKAROUND: browseURL('foo/bar.html', browser=NULL), which in turn
  # calls shell.exec('foo/bar.html'), does not work on Windows, because
  # the OS expects backslashes.  [Should shell.exec() convert to
  # backslashes?]  By temporarily setting the working directory to that
  # of the file, view() for RspFileProduct works around this issue.
  if (isFile(object)) {
    path <- dirname(object)
    pathname <- basename(object)
    opwd <- getwd()
    on.exit(setwd(opwd))
    setwd(path)
  } else {
    pathname <- object
  }
  browseURL(pathname, ...)
  invisible(object)
}, proctected=TRUE)



setMethodS3("getType", "RspFileProduct", function(object, default=NA_character_, as=c("text", "IMT"), ...) {
  as <- match.arg(as)
  res <- NextMethod("getType", default=NA_character_)

  if (is.na(res)) {
    # Infer type from the filename extension?
    if (isFile(object) || isUrl(object)) {
      res <- extensionToIMT(object)
    }
  }

  # Fall back to a default?
  if (is.na(res)) {
    default <- as.character(default)
    res <- default
  }

  if (as == "IMT" && !is.na(res)) {
    res <- parseInternetMediaType(res)
  }

  res
}, protected=TRUE)


setMethodS3("getFileSize", "RspFileProduct", function(object, what=c("numeric", "units"), sep="", ...) {
  # Argument 'what':
  what <- match.arg(what)

  pathname <- object
  if (is.null(pathname) && isUrl(pathname)) {
    fileSize <- NA_real_
  } else {
    fileSize <- file.info2(pathname)$size
  }

  if (what == "numeric")
    return(fileSize)

  if (is.na(fileSize))
    return(fileSize)

  units <- c("bytes", "kB", "MB", "GB", "TB")
  scale <- 1
  for (kk in seq_along(units)) {
    unit <- units[kk]
    if (fileSize < 1000)
      break
    fileSize <- fileSize/1024
  }
  fileSize <- sprintf("%.2f %s%s", fileSize, sep, unit)
  fileSize <- gsub(".00 bytes", " bytes", fileSize, fixed=TRUE)

  fileSize
})



setMethodS3("findProcessor", "RspFileProduct", function(object, ..., verbose=FALSE) {
  isFALSE <- function(x) {
    if (is.character(x)) return(toupper(x) == "FALSE")
    if (is.logical(x) && !x) return(TRUE)
    FALSE
  }

  localCompileLaTeX <- function(..., texinputs=NULL) {
    if (!is.null(source)) {
      path <- dirname(source)
      pathA <- getAbsolutePath(path)
      texinputs <- c(texinputs, pathA)
    }
    compileLaTeX(..., texinputs=texinputs)
  } # localCompileLaTeX()


  localCompressPDF <- function(pathname, ..., verbose=FALSE) {
    # Argument 'verbose':
    verbose <- Arguments$getVerbose(verbose)
    if (verbose) {
      pushState(verbose)
      on.exit(popState(verbose))
    }

    ## Disabling further postprocessing after this,
    ## which avoids recursive loop.
    metadata <- attr(pathname, "metadata")
    metadata$postprocess <- FALSE
    attr(pathname, "metadata") <- metadata

    ## Get compression level
    compression <- metadata$compression

    verbose && enter(verbose, "Trying to compress PDF")
    verbose && cat(verbose, "Compression: ", compression)

    pathT <- tempfile(pattern=".dir", tmpdir=".")
    on.exit(removeDirectory(pathT, recursive=TRUE), add=TRUE)

    ## ROBUSTNESS: If compression fails for one reason or the
    ## other, fall back to keep the non-compressed version.
    tryCatch({
      verbose && enter(verbose, "R.utils::compressPDF()...")
      suppressWarnings({
        pathnameZ <- compressPDF(pathname, outPath=pathT,
                                 compression=compression)
      })
      verbose && exit(verbose)

      size <- file.info(pathname)$size
      sizeZ <- file.info(pathnameZ)$size
      if (!identical(sizeZ, size)) {
        renameFile(pathnameZ, pathname, overwrite=TRUE)
      }
    }, error = function(ex) {
      msg <- sprintf("Compression of '%s' using '%s' failed. Keeping the original PDF file. Reason was: %s", pathname, compression, ex$message)
      verbose && cat(verbose, msg)
      warning(msg)
    })

    verbose && exit(verbose)

    pathname
  } # localCompressPDF()


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }


  verbose && enter(verbose, "Locating document-type specific processor")
  type <- getType(object)
  verbose && cat(verbose, "RSP product content type: ", type)

  # Nothing to do?
  if (is.na(type)) {
    verbose && cat(verbose, "Processor found: <none>")
    verbose && exit(verbose)
    return(NULL)
  }
  type <- parseInternetMediaType(type)$contentType


  # Nothing to do?
  postprocess <- getMetadata(object, "postprocess", local=TRUE)
  if (isFALSE(postprocess)) {
    verbose && cat(verbose, "Processing disabled: metadata variable 'postprocess' is FALSE")
    verbose && exit(verbose)
    return(NULL)
  }


  source <- getMetadata(object, "source", local=TRUE)
  if (is.null(source)) {
    verbose && cat(verbose, "Source document: <unknown>")
  } else {
    verbose && cat(verbose, "Source document: ", sQuote(source))
  }



  # Find a down-stream compiler/processor:
  fcn <- switch(type,
    # RSP documents:
    # *<ext>.rsp => *.<ext>
    "application/x-rsp" = function(...) { compileRsp(..., postprocess=FALSE) },

    # LaTeX documents:
    # *.tex => ... => *.pdf
    "application/x-tex" = localCompileLaTeX,
    "application/x-latex" = localCompileLaTeX,

    ## PDF documents:
    # *.pdf => ... => *.pdf
    "application/pdf" = localCompressPDF,

    # Markdown documents:
    # *.md => *.html
    "application/x-markdown" = compileMarkdown,

    # Markdown documents:
    # *.txt => *.html, ...
    "application/x-asciidoc" = function(...) { compileAsciiDoc(..., postprocess=FALSE) },

    # Sweave Rnw documents:
    # *.Rnw => *.tex
    "application/x-sweave" = function(...) { compileSweave(..., postprocess=FALSE) },

    # Knitr Rnw documents:
    # *.Rnw => *.tex
    "application/x-knitr" = function(...) { compileKnitr(..., postprocess=FALSE) },

    # Knitr Rmd documents:
    # *.Rmd => *.html
    "application/x-rmd" = function(...) { compileKnitr(..., postprocess=FALSE) },
    # Knitr Rhtml documents:
    # *.Rhtml => *.html
    "application/x-rhtml" = function(...) { compileKnitr(..., postprocess=FALSE) },

    # Knitr Rtex documents:
    # *.Rtex => *.tex
    "application/x-rtex" = function(...) { compileKnitr(..., postprocess=FALSE) },

    # Knitr Rrst documents:
    # *.Rrst => *.rst
    "application/x-rrst" = function(...) { compileKnitr(..., postprocess=FALSE) },

    # AsciiDoc Rnw documents:
    # *.Rnw => *.txt
    "application/x-asciidoc-noweb" = function(...) { compileAsciiDocNoweb(..., postprocess=FALSE) },

    # Sweave or Knitr Rnw documents:
    # *.Rnw => *.tex
    "application/x-rnw" = function(...) { compileRnw(..., postprocess=FALSE) }
  )

  if (is.null(fcn)) {
    verbose && cat(verbose, "Processor found: <none>")
  } else {
    # Get the metadata attributes
    metadata <- getMetadata(object, local=TRUE)

    # Make sure the processor returns an RspFileProduct
    fcnT <- fcn
    processor <- function(...) {
       do.call(fcnT, args=c(list(...), list(metadata=metadata)))
    }

    fcn <- function(pathname, ...) {
      # Arguments 'pathname':
      if (!isUrl(pathname)) {
        withoutGString({
          pathnameT <- Arguments$getReadablePathname(pathname)
          pathname[1] <- pathnameT;  ## Preserve class and attributes etc.
        })
      }

      # NOTE: It is not sure that the processor supports URLs
      pathnameR <- processor(pathname, ...)

      ## Check if further postprocessoring should be disabled
      metadataR <- getMetadata(pathnameR)
      postprocessR <- getMetadata(pathnameR, "postprocess", local=TRUE)
      if (isFALSE(postprocessR)) metadata$postprocess <- FALSE

      # Always return the relative path
      pathnameR <- getAbsolutePath(pathnameR)
      res <- RspFileProduct(pathnameR, attrs=list(metadata=metadata), mustExist=FALSE)
      res <- setMetadata(res, name="source", value=pathname)

      res
    } # fcn()
    verbose && cat(verbose, "Processor found: ", type)
  }

  verbose && exit(verbose)

  fcn
}, protected=TRUE) # findProcessor()

Read our documentation on viewing source code .

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

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