helper_vignettes.R 3.92 KB
Newer Older
1
2
3
4
5
#' Extract chunks from Rmd files (knitr::purl) and source them
#'
#' @param fileRmd Rmd file to
#' @param tmpFolder Folder storing the script containing extracted chunks
#' @param force.eval Force execution of chunks with parameter eval=FALSE
6
7
8
RunRmdChunks <- function(fileRmd,
                         tmpFolder = "../tmp",
                         force.eval = TRUE) {
9
  dir.create(tmpFolder, showWarnings = FALSE)
10
  output <- file.path(tmpFolder,
11
                      gsub("\\.Rmd", "\\.R", basename(fileRmd), ignore.case = TRUE))
12
  knitr::purl(fileRmd, output = output, quiet = TRUE)
13
  sTxt <- readLines(output)
14
  if (force.eval) {
15
16
    sectionLines <- grep("^## ----", sTxt)
    chunksEvalStart <- grep("^## ----.*eval=F", sTxt)
17
18
    if (length(chunksEvalStart) > 0) {
      if (sectionLines[length(sectionLines)] == chunksEvalStart[length(chunksEvalStart)]) {
19
        lastEvalStart <- length(chunksEvalStart) - 1
20
      } else {
21
        lastEvalStart <- length(chunksEvalStart)
22
23
      }
      # Search for end lines of eval=F chunks
24
25
      chunksEvalEnd <- sectionLines[sapply(chunksEvalStart[1:lastEvalStart], function(x) {which(sectionLines == x)}) + 1] - 1
      if (lastEvalStart) {
26
        # Add last line if last chunk is eval=FALSE
27
        chunksEvalEnd <- c(chunksEvalEnd, length(sTxt))
28
      }
29
      chunksEvalStart <- chunksEvalStart + 1 # Chunks begin one line after the section comment
30
31
      for (i in 1:length(chunksEvalStart)) {
        # Remove comments on eval=F chunk lines
32
        sTxt[chunksEvalStart[i]:chunksEvalEnd[i]] <- gsub(pattern = "^## ",
33
34
                                                          replace = "",
                                                          x = sTxt[chunksEvalStart[i]:chunksEvalEnd[i]])
35
36
      }
    }
37

38
39
40
41
42
43
44
45
46
47
48
49
  }
  # Remove line of code displaying data
  removeFromGrep <- function(pattern, x) {
    i <- grep(pattern, x)
    if (length(i) > 0) {
      x <- x[-i]
    }
    return(x)
  }
  sTxt <- removeFromGrep("^summary\\(.*\\)$", sTxt)
  sTxt <- removeFromGrep("^str\\(.*\\)$", sTxt)
  # Switch echo off for some functions
50
  sTxt <- gsub("trace\\s?=\\s?[0-9]+", "trace = 0", sTxt)
51
  # Add parameters to example calls
52
53
  exLines <- grep("^example\\(.*\\)", sTxt)
  sTxt[exLines] <- paste0(substr(sTxt[exLines], 1, nchar(sTxt[exLines]) - 1), ", echo = FALSE, verbose = FALSE, ask = FALSE)")
54
  # Remove question "Hit <Return> to see next plot"
55
  sTxt <- c("par(ask=F)", sTxt)
56
57
58
  # Write the transformed script
  writeLines(sTxt, output)
  # Silently run the chunks
59
  invisible(capture.output(suppressMessages(suppressWarnings(source(output))), type = "output"))
60
  return(TRUE)
61
}
62

63
64
65
66
67
68
69
70
71
72
#' Extract chunks from vignette and source them
#'
#' @param vignette Name of the vignette
#' @param tmpFolder Folder storing the script containing extracted chunks
#' @param force.eval Force execution of chunks with parameter eval=FALSE
#'
#' @return TRUE if succeed.
RunVignetteChunks <- function(vignette,
                              tmpFolder = "../tmp",
                              force.eval = TRUE) {
73
  if(file.exists(sprintf("../../vignettes/%s.Rmd", vignette))) {
74
    # testthat context in development environnement
75
    RunRmdChunks(sprintf("../../vignettes/%s.Rmd", vignette), tmpFolder, force.eval)
76
77
  } else {
    # R CMD check context in package environnement
78
    RunRmdChunks(system.file(sprintf("doc/%s.Rmd", vignette), package = "airGR"), tmpFolder, force.eval)
79
80
81
  }
  return(TRUE)
}
82
83
84
85
86
87
88

#' Test if conversion from Q in mm per day into Q in L/s is good in BasinObs
#'
#' @param BasinObs A dataframe containing columns Qmm and Qls
#' @param BasinArea Area of the basin in km2
#' @param tolerance See ?all.equal
#'
89
#' @return
90
TestQmmQlsConversion <- function(BasinObs, BasinArea, tolerance = 1E-7) {
91
92
93
94
  Conversion <- BasinArea * 1000^2 / 1000 * 1000 # km2 -> m2, mm -> m and m3 -> L
  Conversion <- Conversion / 86400 # Day -> seconds
  notNA <- which(!is.na(BasinObs$Qmm))
  expect_equal(BasinObs$Qmm[notNA] * Conversion, BasinObs$Qls[notNA], tolerance = tolerance)
95
}