Commit 6629f998 authored by Delaigue Olivier's avatar Delaigue Olivier

Merge branch '52-implement-automatic-tests-in-the-package' into 'dev'

Resolve "Implement automatic tests in the package"

Closes #52

See merge request !8
parents 568b1945 94452aee
Pipeline #12582 passed with stages
in 9 minutes and 45 seconds
# Specific files for airGR
packrat/lib*/
# Compiled files
/src/*.o
/src/*.dll
/src-*
# Test temporary files
/tests/tmp/
/tests/testthat/*.pdf
######################################################################################################
### Generic .gitignore for R (source: https://github.com/github/gitignore/blob/master/R.gitignore) ###
######################################################################################################
......
stages:
- build
- tests
build:
stage: build
script:
- cd ..
- echo "setwd(\"$(pwd)\")" > .Rprofile
- R CMD build airgr
- mv *.tar.gz airgr/
artifacts:
untracked: true
expire_in: 1 week
check_not_cran:
stage: tests
script:
- echo "setwd(\"$(pwd)\")" > .Rprofile
- echo "Sys.setenv(NOT_CRAN = \"true\")" >> .Rprofile
- R CMD check airGR_*.tar.gz
check_as_cran:
stage: tests
script:
- echo "setwd(\"$(pwd)\")" > .Rprofile
- R CMD check --as-cran airGR_*.tar.gz
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.4.3.87
Date: 2020-04-16
Version: 1.4.3.88
Date: 2020-04-24
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
person("Olivier", "Delaigue", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7668-8468"), email = "airGR@inrae.fr"),
......@@ -20,7 +20,7 @@ Authors@R: c(
person("Audrey", "Valéry", role = c("ctb"))
)
Depends: R (>= 3.0.1)
Suggests: knitr, rmarkdown, coda, DEoptim, dplyr, FME, ggmcmc, hydroPSO, Rmalschains
Suggests: knitr, rmarkdown, coda, DEoptim, dplyr, FME, ggmcmc, hydroPSO, Rmalschains, testthat
Description: Hydrological modelling tools developed at INRAE-Antony (HYCAR Research Unit, France). The package includes several conceptual rainfall-runoff models (GR4H, GR5H, GR4J, GR5J, GR6J, GR2M, GR1A), a snow accumulation and melt model (CemaNeige) and the associated functions for their calibration and evaluation. Use help(airGR) for package description and references.
License: GPL-2
URL: https://hydrogr.github.io/airGR/
......
......@@ -4,11 +4,12 @@
### 1.4.3.87 Release Notes (2020-04-16)
### 1.4.3.88 Release Notes (2020-04-24)
#### Version control and issue tracking
- Update .gitignore from https://github.com/github/gitignore/blob/master/R.gitignore ([#53](https://gitlab.irstea.fr/HYCAR-Hydro/airgr/-/issues/53))
- Implement automatic tests in the package. ([#52](https://gitlab.irstea.fr/HYCAR-Hydro/airgr/-/issues/52))
#### CRAN-compatibility updates
......
library(testthat)
library(airGR)
test_check("airGR")
#' 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
RunRmdChunks <- function(fileRmd,
tmpFolder = "../tmp",
force.eval = TRUE) {
dir.create(tmpFolder, showWarnings = FALSE)
output <- file.path(tmpFolder,
gsub("\\.Rmd", "\\.R", basename(fileRmd), ignore.case = TRUE))
knitr::purl(fileRmd, output = output, quiet = TRUE)
sTxt <- readLines(output)
if (force.eval) {
sectionLines <- grep("^## ----", sTxt)
chunksEvalStart <- grep("^## ----.*eval=F", sTxt)
if (length(chunksEvalStart) > 0) {
if (sectionLines[length(sectionLines)] == chunksEvalStart[length(chunksEvalStart)]) {
lastEvalStart <- length(chunksEvalStart) - 1
} else {
lastEvalStart <- length(chunksEvalStart)
}
# Search for end lines of eval=F chunks
chunksEvalEnd <- sectionLines[sapply(chunksEvalStart[1:lastEvalStart], function(x) {which(sectionLines == x)}) + 1] - 1
if (lastEvalStart) {
# Add last line if last chunk is eval=FALSE
chunksEvalEnd <- c(chunksEvalEnd, length(sTxt))
}
chunksEvalStart <- chunksEvalStart + 1 # Chunks begin one line after the section comment
for (i in 1:length(chunksEvalStart)) {
# Remove comments on eval=F chunk lines
sTxt[chunksEvalStart[i]:chunksEvalEnd[i]] <- gsub(pattern = "^## ",
replace = "",
x = sTxt[chunksEvalStart[i]:chunksEvalEnd[i]])
}
}
}
# 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
sTxt <- gsub("trace\\s?=\\s?[0-9]+", "trace = 0", sTxt)
# Add parameters to example calls
exLines <- grep("^example\\(.*\\)", sTxt)
sTxt[exLines] <- paste0(substr(sTxt[exLines], 1, nchar(sTxt[exLines]) - 1), ", echo = FALSE, verbose = FALSE, ask = FALSE)")
# Remove question "Hit <Return> to see next plot"
sTxt <- c("par(ask=F)", sTxt)
# Write the transformed script
writeLines(sTxt, output)
# Silently run the chunks
invisible(capture.output(suppressMessages(suppressWarnings(source(output))), type = "output"))
return(TRUE)
}
#' 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) {
if(file.exists(file.path("../../vignettes/", paste0(vignette, ".Rmd")))) {
# testthat context in development environnement
RunRmdChunks(file.path("../../vignettes/", paste0(vignette, ".Rmd")), tmpFolder, force.eval)
} else {
# R CMD check context in package environnement
RunRmdChunks(system.file(file.path("doc/", paste0(vignette, ".Rmd")), package = "airGR"), tmpFolder, force.eval)
}
return(TRUE)
}
#' 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
#'
#' @return
TestQmmQlsConversion <- function(BasinObs, BasinArea, tolerance = 1E-7) {
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)
}
\ No newline at end of file
context("Test vignette chunks")
test_that("V01_get_started works", {
skip_on_cran()
rm(list = ls())
expect_true(RunVignetteChunks("V01_get_started"))
TestQmmQlsConversion(BasinObs, BasinInfo$BasinArea)
})
test_that("V02.1_param_optim works", {
skip_on_cran()
rm(list = ls())
load(system.file("vignettesData/vignetteParamOptim.rda", package = "airGR"))
rda_resGLOB <- resGLOB
rda_resPORT <- resPORT
expect_true(RunVignetteChunks("V02.1_param_optim"))
expect_equal(summary(resGLOB), summary(rda_resGLOB), tolerance = 1E-7)
resGLOB <- data.frame(Algo = c("airGR", "PORT", "DE", "PSO", "MA-LS"),
round(rbind(
OutputsCalib$ParamFinalR ,
airGR::TransfoParam_GR4J(ParamIn = optPORT$par , Direction = "TR"),
airGR::TransfoParam_GR4J(ParamIn = as.numeric(optDE$optim$bestmem), Direction = "TR"),
rda_resGLOB[4, c("X1", "X2", "X3", "X4")],
airGR::TransfoParam_GR4J(ParamIn = optMALS$sol , Direction = "TR")),
digits = 3))
expect_equal(resGLOB[,-1], rda_resGLOB[,-1], tolerance = 1E-2) # High tolerance due to randomisation in optimisations
})
test_that("V02.2_param_mcmc works", {
skip_on_cran()
rm(list = ls())
load(system.file("vignettesData/vignetteParamMCMC.rda", package = "airGR"))
rda_gelRub <- gelRub
rda_multDRAM <- multDRAM
expect_true(RunVignetteChunks("V02.2_param_mcmc"))
expect_equal(gelRub, rda_gelRub, tolerance = 1E-7)
expect_equal(multDRAM, rda_multDRAM, tolerance = 1E-7)
})
test_that("V03_param_sets_GR4J works", {
skip_on_cran()
rm(list = ls())
expect_true(RunVignetteChunks("V03_param_sets_GR4J"))
})
test_that("V04_cemaneige_hysteresis works", {
skip_on_cran()
rm(list = ls())
load(system.file("vignettesData/vignetteCNHysteresis.rda", package = "airGR"))
rda_OutputsCrit_Cal <- OutputsCrit_Cal
rda_OutputsCrit_Cal_NoHyst <- OutputsCrit_Cal_NoHyst
rda_OutputsCrit_Val <- OutputsCrit_Val
rda_OutputsCrit_Val_NoHyst <- OutputsCrit_Val_NoHyst
expect_true(RunVignetteChunks("V04_cemaneige_hysteresis"))
TestQmmQlsConversion(BasinObs, BasinInfo$BasinArea)
expect_equal(OutputsCrit_Cal, rda_OutputsCrit_Cal, tolerance = 1E-7)
expect_equal(OutputsCrit_Cal_NoHyst, rda_OutputsCrit_Cal_NoHyst, tolerance = 1E-7)
expect_equal(OutputsCrit_Val, rda_OutputsCrit_Val, tolerance = 1E-7)
expect_equal(OutputsCrit_Val_NoHyst, rda_OutputsCrit_Val_NoHyst, tolerance = 1E-7)
})
......@@ -13,7 +13,7 @@ vignette: >
```{r, warning=FALSE, include=FALSE, fig.keep='none', results='hide'}
library(airGR)
library(DEoptim)
library(hydroPSO)
library(hydroPSO) # Needs R version >= 3.6 or latticeExtra <= 0.6-28 on R 3.5
library(Rmalschains)
# source("airGR.R")
set.seed(321)
......@@ -84,7 +84,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}
startGR4J <- c(4.1, 3.9, -0.9, -8.7)
optPORT <- stats::nlminb(start = startGR4J,
optPORT <- stats::nlminb(start = startGR4J,
objective = OptimGR4J,
lower = lowerGR4J, upper = upperGR4J,
control = list(trace = 1))
......@@ -97,7 +97,7 @@ For each starting point, a local optimization is performed.
```{r, warning=FALSE, results='hide', eval=FALSE}
startGR4J <- expand.grid(data.frame(CalibOptions$StartParamDistrib))
optPORT_ <- function(x) {
opt <- stats::nlminb(start = x,
opt <- stats::nlminb(start = x,
objective = OptimGR4J,
lower = lowerGR4J, upper = upperGR4J,
control = list(trace = 1))
......@@ -138,7 +138,7 @@ optDE <- DEoptim::DEoptim(fn = OptimGR4J,
## Particle Swarm
```{r, warning=FALSE, results='hide', message=FALSE, eval=FALSE}
```{r, warning=FALSE, results='hide', message=FALSE, eval=FALSE, purl=FALSE}
optPSO <- hydroPSO::hydroPSO(fn = OptimGR4J,
lower = lowerGR4J, upper = upperGR4J,
control = list(write2disk = FALSE, verbose = FALSE))
......@@ -147,7 +147,7 @@ optPSO <- hydroPSO::hydroPSO(fn = OptimGR4J,
## MA-LS-Chains
```{r, warning=FALSE, results='hide', eval=FALSE}
optMALS <- Rmalschains::malschains(fn = OptimGR4J,
lower = lowerGR4J, upper = upperGR4J,
lower = lowerGR4J, upper = upperGR4J,
maxEvals = 2000)
```
......@@ -155,8 +155,8 @@ optMALS <- Rmalschains::malschains(fn = OptimGR4J,
As it can be seen in the table below, the four additional optimization strategies tested lead to very close optima.
```{r, warning=FALSE, echo=FALSE, eval=FALSE}
resGLOB <- data.frame(Algo = c("airGR", "PORT", "DE", "PSO", "MA-LS"),
```{r, warning=FALSE, echo=FALSE, eval=FALSE, purl=FALSE}
resGLOB <- data.frame(Algo = c("airGR", "PORT", "DE", "PSO", "MA-LS"),
round(rbind(
OutputsCalib$ParamFinalR ,
airGR::TransfoParam_GR4J(ParamIn = optPORT$par , Direction = "TR"),
......
......@@ -48,8 +48,8 @@ Please note that this vignette is only for illustration purposes and does not pr
We show how to use the DRAM algorithm for SLS Bayesian inference, with the `modMCMC()` function of the [FME](https://cran.r-project.org/package=FME) package.
First, we need to define a function that returns twice the opposite of the log-likelihood for a given parameter set.
Nota: in the `LogLikeGR4J()` function, the computation of the log-likelihood is simplified in order to ensure a good computing performance. It corresponds to a translation of the two following lines.
```{r, echo=TRUE, eval=FALSE}
Nota: in the `LogLikeGR4J()` function, the computation of the log-likelihood is simplified in order to ensure a good computing performance. It corresponds to a translation of the two following lines.
```{r, echo=TRUE, eval=FALSE, purl=FALSE}
Likelihood <- sum((ObsY - ModY)^2, na.rm = TRUE)^(-sum(!is.na(ObsY)) / 2)
LogLike <- -2 * log(Likelihood)
```
......@@ -68,7 +68,7 @@ LogLikeGR4J <- function(ParamOptim) {
RunOptions = RunOptions,
Param = RawParamOptim)
## Computation of the log-likelihood: N * log(SS)
ObsY <- InputsCrit$Qobs
ObsY <- InputsCrit$Obs
ModY <- OutputsModel$Qsim
LogLike <- sum(!is.na(ObsY)) * log(sum((ObsY - ModY)^2, na.rm = TRUE))
}
......@@ -79,7 +79,7 @@ LogLikeGR4J <- function(ParamOptim) {
## Estimation of the best-fit parameters as a starting point
We start by using the PORT optimization routine to estimate the best-fit parameters.
```{r, results='hide', eval=FALSE}
optPORT <- stats::nlminb(start = c(4.1, 3.9, -0.9, -8.7),
optPORT <- stats::nlminb(start = c(4.1, 3.9, -0.9, -8.7),
objective = LogLikeGR4J,
lower = rep(-9.9, times = 4), upper = rep(9.9, times = 4),
control = list(trace = 1))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment