From ef0d8151b07d9a095b46701d968698101fbb3ed7 Mon Sep 17 00:00:00 2001
From: David Dorchies <david.dorchies@inrae.fr>
Date: Fri, 20 Oct 2023 13:28:33 +0200
Subject: [PATCH] tests: add vignettechunkignore feature
For handling hydroPSO exception on V02
Refs #175
---
.vignettechunkignore | 6 ++++
tests/testthat/helper_vignettes.R | 50 +++++++++++++++++++++++++++----
vignettes/V02.1_param_optim.Rmd | 24 +++++++--------
3 files changed, 62 insertions(+), 18 deletions(-)
create mode 100644 .vignettechunkignore
diff --git a/.vignettechunkignore b/.vignettechunkignore
new file mode 100644
index 00000000..4ad31d40
--- /dev/null
+++ b/.vignettechunkignore
@@ -0,0 +1,6 @@
+# This file is used by the script tests/testthat/test-vignettes which test all
+# chunks including those with `eval=FALSE`
+# It serves to ignore chunks that should not be tested anyway
+# Format: `path to the vignette`[space]`id of the chunk`
+vignettes/V02.1_param_optim.Rmd hydroPSO1
+vignettes/V02.1_param_optim.Rmd hydroPSO2
diff --git a/tests/testthat/helper_vignettes.R b/tests/testthat/helper_vignettes.R
index 98951fef..563da27f 100644
--- a/tests/testthat/helper_vignettes.R
+++ b/tests/testthat/helper_vignettes.R
@@ -5,7 +5,8 @@
#' @param force.eval Force execution of chunks with parameter eval=FALSE
RunRmdChunks <- function(fileRmd,
tmpFolder = "../tmp",
- force.eval = TRUE) {
+ force.eval = TRUE,
+ chunkIgnore = getChunkIgnore()) {
dir.create(tmpFolder, showWarnings = FALSE)
output <- file.path(tmpFolder,
gsub("\\.Rmd", "\\.R", basename(fileRmd), ignore.case = TRUE))
@@ -13,7 +14,13 @@ RunRmdChunks <- function(fileRmd,
sTxt <- readLines(output)
if (force.eval) {
sectionLines <- grep("^## ----", sTxt)
- chunksEvalStart <- grep("^## ----.*eval=F", sTxt)
+ chunkIgnore <- chunkIgnore[[fileRmd]]
+ if (!is.null(chunkIgnore)) {
+ regexChunk <- sprintf("(?!(%s))", paste(chunkIgnore, collapse = "|"))
+ } else {
+ regexChunk <- ""
+ }
+ chunksEvalStart <- grep(paste0("^## ----", regexChunk, ".*eval=F"), sTxt, ignore.case=TRUE, perl = TRUE)
if (length(chunksEvalStart) > 0) {
if (sectionLines[length(sectionLines)] == chunksEvalStart[length(chunksEvalStart)]) {
lastEvalStart <- length(chunksEvalStart) - 1
@@ -69,16 +76,26 @@ RunRmdChunks <- function(fileRmd,
#' @return TRUE if succeed.
RunVignetteChunks <- function(vignette,
tmpFolder = "../tmp",
- force.eval = TRUE) {
+ force.eval = TRUE,
+ chunkIgnore = getChunkIgnore()) {
if (file.exists(sprintf("../../vignettes/%s.Rmd", vignette))) {
# testthat context in development environnement
- RunRmdChunks(sprintf("../../vignettes/%s.Rmd", vignette), tmpFolder, force.eval)
+ RunRmdChunks(sprintf("../../vignettes/%s.Rmd", vignette),
+ tmpFolder = tmpFolder,
+ force.eval =force.eval,
+ chunkIgnore = chunkIgnore)
} else if (file.exists(sprintf("vignettes/%s.Rmd", vignette))) {
# context in direct run in development environnement
- RunRmdChunks(sprintf("vignettes/%s.Rmd", vignette), tmpFolder, force.eval)
+ RunRmdChunks(sprintf("vignettes/%s.Rmd", vignette),
+ tmpFolder = tmpFolder,
+ force.eval =force.eval,
+ chunkIgnore = chunkIgnore)
} else {
# R CMD check context in package environnement
- RunRmdChunks(system.file(sprintf("doc/%s.Rmd", vignette), package = "airGR"), tmpFolder, force.eval)
+ RunRmdChunks(system.file(sprintf("doc/%s.Rmd", vignette), package = "airGR"),
+ tmpFolder = tmpFolder,
+ force.eval =force.eval,
+ chunkIgnore = chunkIgnore)
}
return(TRUE)
}
@@ -96,3 +113,24 @@ TestQmmQlsConversion <- function(BasinObs, BasinArea, tolerance = 1E-7) {
notNA <- which(!is.na(BasinObs$Qmm))
expect_equal(BasinObs$Qmm[notNA] * Conversion, BasinObs$Qls[notNA], tolerance = tolerance)
}
+
+#' Read vignettechunkignore file
+#'
+#' @param chunkIgnoreFile path to the file
+#'
+#' @return [list] with one item by vignette containing the chunk id to ignore
+#'
+getChunkIgnore <- function(chunkIgnoreFile = "../../.vignettechunkignore") {
+ if (file.exists(chunkIgnoreFile)) {
+ chunkIgnore <- read.table(file = chunkIgnoreFile,
+ sep = " ", header = FALSE,
+ col.names = c("vignette", "chunk"),
+ stringsAsFactors = FALSE)
+ chunkIgnore <- lapply(setNames(nm = unique(chunkIgnore$vignette)), function(x) {
+ chunkIgnore$chunk[chunkIgnore$vignette == x]
+ })
+ } else {
+ chunkIgnore <- list()
+ }
+ return(chunkIgnore)
+}
diff --git a/vignettes/V02.1_param_optim.Rmd b/vignettes/V02.1_param_optim.Rmd
index 6c43ac85..71d75b19 100644
--- a/vignettes/V02.1_param_optim.Rmd
+++ b/vignettes/V02.1_param_optim.Rmd
@@ -10,7 +10,7 @@ vignette: >
-```{r, warning=FALSE, include=FALSE, fig.keep='none', results='hide'}
+```{r setup, warning=FALSE, include=FALSE, fig.keep='none', results='hide'}
library(airGR)
library(DEoptim)
# library(hydroPSO) # Needs R version >= 3.6 or latticeExtra <= 0.6-28 on R 3.5. Archived on 2023-10-16 as requires archived packages 'hydroTSM' and 'hydroGOF'.
@@ -41,13 +41,13 @@ Please note that the calibration period is defined in the `CreateRunOptions()` f
<!-- example("Calibration_Michel", echo = FALSE, ask = FALSE) -->
<!-- ``` -->
-```{r, echo=TRUE, eval=FALSE}
+```{r Calibration_Michel, echo=TRUE, eval=FALSE}
example("Calibration_Michel")
```
In order for the `RunModel_*()` functions to run faster during the parameter estimation process, it is recommended that the outputs contain only the simulated flows (see the `Outputs_Sim` argument in the `CreateRunOptions()` help page).
-```{r, results='hide', eval=FALSE}
+```{r RunOptions, results='hide', eval=FALSE}
RunOptions <- airGR::CreateRunOptions(FUN_MOD = RunModel_GR4J, InputsModel = InputsModel,
IndPeriod_Run = Ind_Run,
Outputs_Sim = "Qsim")
@@ -66,7 +66,7 @@ Here we choose to minimize the root mean square error.
The change of the repository from the "real" parameter space to a "transformed" space ensures homogeneity of displacement in the different dimensions of the parameter space during the step-by-step procedure of the calibration algorithm of the model.
-```{r, warning=FALSE, results='hide', eval=FALSE}
+```{r OptimGR4J, warning=FALSE, results='hide', eval=FALSE}
OptimGR4J <- function(ParamOptim) {
## Transformation of the parameter set to real space
RawParamOptim <- airGR::TransfoParam_GR4J(ParamIn = ParamOptim,
@@ -86,7 +86,7 @@ OptimGR4J <- function(ParamOptim) {
In addition, we need to define the lower and upper bounds of the four **GR4J** parameters in the transformed parameter space:
-```{r, warning=FALSE, results='hide', eval=FALSE}
+```{r boundsGR4J, warning=FALSE, results='hide', eval=FALSE}
lowerGR4J <- rep(-9.99, times = 4)
upperGR4J <- rep(+9.99, times = 4)
```
@@ -97,7 +97,7 @@ upperGR4J <- rep(+9.99, times = 4)
We start with a local optimization strategy by using the PORT routines (using the `nlminb()` of the `stats` package) and by setting a starting point in the transformed parameter space:
-```{r, warning=FALSE, results='hide', eval=FALSE}
+```{r local1, warning=FALSE, results='hide', eval=FALSE}
startGR4J <- c(4.1, 3.9, -0.9, -8.7)
optPORT <- stats::nlminb(start = startGR4J,
objective = OptimGR4J,
@@ -111,7 +111,7 @@ We can also try a multi-start approach to test the consistency of the local opti
Here we use the same grid used for the filtering step of the Michel's calibration strategy (`Calibration_Michel()` function).
For each starting point, a local optimization is performed.
-```{r, warning=FALSE, results='hide', eval=FALSE}
+```{r local2, warning=FALSE, results='hide', eval=FALSE}
startGR4JDistrib <- TransfoParam_GR4J(ParamIn = CalibOptions$StartParamDistrib,
Direction = "RT")
startGR4J <- expand.grid(data.frame(startGR4JDistrib))
@@ -126,7 +126,7 @@ listOptPORT <- apply(startGR4J, MARGIN = 1, FUN = optPORT_)
We can then extract the best parameter sets and the value of the performance criteria:
-```{r, warning=FALSE, results='hide', eval=FALSE}
+```{r local3, warning=FALSE, results='hide', eval=FALSE}
parPORT <- t(sapply(listOptPORT, function(x) x$par))
objPORT <- sapply(listOptPORT, function(x) x$objective)
resPORT <- data.frame(parPORT, RMSE = objPORT)
@@ -134,7 +134,7 @@ resPORT <- data.frame(parPORT, RMSE = objPORT)
As can be seen below, the optimum performance criterion values (column *objective*) can differ from the global optimum value in many cases, resulting in various parameter sets.
-```{r, warning=FALSE}
+```{r local4, warning=FALSE}
summary(resPORT)
```
@@ -154,7 +154,7 @@ Here we use the following R implementation of some popular strategies:
## Differential Evolution
-```{r, warning=FALSE, results='hide', eval=FALSE}
+```{r optDE, warning=FALSE, results='hide', eval=FALSE}
optDE <- DEoptim::DEoptim(fn = OptimGR4J,
lower = lowerGR4J, upper = upperGR4J,
control = DEoptim::DEoptim.control(NP = 40, trace = 10))
@@ -163,7 +163,7 @@ optDE <- DEoptim::DEoptim(fn = OptimGR4J,
## Particle Swarm
-```{r, warning=FALSE, results='hide', message=FALSE, eval=FALSE}
+```{r hydroPSO1, warning=FALSE, results='hide', message=FALSE, eval=FALSE}
# to install the package temporary removed from CRAN
# Rtools needed (windows : https://cran.r-project.org/bin/windows/Rtools/)
# install.packages("https://cran.r-project.org/src/contrib/Archive/hydroPSO/hydroPSO_0.5-1.tar.gz",
@@ -171,7 +171,7 @@ optDE <- DEoptim::DEoptim(fn = OptimGR4J,
```
-```{r, warning=FALSE, results='hide', message=FALSE, eval=FALSE}
+```{r hydroPSO2, warning=FALSE, results='hide', message=FALSE, eval=FALSE}
optPSO <- hydroPSO::hydroPSO(fn = OptimGR4J,
lower = lowerGR4J, upper = upperGR4J,
control = list(write2disk = FALSE, verbose = FALSE))
--
GitLab