Commit 267ee1b7 authored by Delaigue Olivier's avatar Delaigue Olivier
Browse files

Merge branch '120-add-test-using-calibration-algorithm-with-all-models' into 'dev'

Resolve "Add test using calibration algorithm with all models"

Closes #120

See merge request !48
parents 78f5f1e1 82a929a6
Pipeline #23980 passed with stages
in 97 minutes and 5 seconds
stages:
- check
- regression
- scheduled_tests
- revdepcheck
default:
......@@ -10,13 +10,14 @@ default:
- PATH=~/R/sources/R-${R_VERSION}/bin:$PATH
- R -e 'remotes::install_deps(dep = TRUE)'
.regression:
stage: regression
.scheduled_tests:
stage: scheduled_tests
script:
- Rscript tests/testthat/regression_tests.R stable
- Rscript tests/scheduled_tests/scheduled.R
- Rscript tests/scheduled_tests/regression.R stable
- R CMD INSTALL .
- Rscript tests/testthat/regression_tests.R dev
- Rscript tests/testthat/regression_tests.R compare
- Rscript tests/scheduled_tests/regression.R dev
- Rscript tests/scheduled_tests/regression.R compare
.check:
stage: check
......@@ -33,26 +34,31 @@ default:
NOT_CRAN: "false"
extends: .check
regression_patched:
scheduled_tests_patched:
only:
refs:
- dev
- master
- schedules
variables:
R_VERSION: "patched"
extends: .regression
extends: .scheduled_tests
regression_devel:
scheduled_tests_devel:
only:
refs:
- schedules
variables:
R_VERSION: "devel"
extends: .regression
extends: .scheduled_tests
regression_oldrel:
scheduled_tests_oldrel:
only:
refs:
- schedules
variables:
R_VERSION: "oldrel"
extends: .regression
extends: .scheduled_tests
check_not_cran_patched:
variables:
......
# Helper functions for regression
StoreStableExampleResults <- function(
package = "airGR",
path = file.path("tests/tmp", Sys.getenv("R_VERSION"), "stable"),
......@@ -77,7 +79,31 @@ StoreTopicResults <- function(topic, package, path, run.dontrun = TRUE, run.dont
CompareStableDev <- function() {
res <- testthat::test_file("tests/testthat/regression.R")
dRes <- as.data.frame(res)
if(any(dRes[, "failed"] > 0) | any(dRes[, "error"])) {
if (any(dRes[, "failed"] > 0) | any(dRes[, "error"])) {
quit(status = 1)
}
}
###############
# MAIN SCRIPT #
###############
# Execute Regression test by comparing RD files stored in folders /tests/tmp/ref and /tests/tmp/test
Args <- commandArgs(trailingOnly = TRUE)
lActions <- list(
stable = StoreStableExampleResults,
dev = StoreDevExampleResults,
compare = CompareStableDev
)
if (length(Args) == 1 && Args %in% names(lActions)) {
lActions[[Args]]()
} else {
stop("This script should be run with one argument in the command line:\n",
"`Rscript tests/regression_tests.R [stable|dev|compare]`.\n",
"Available arguments are:\n",
"- stable: install stable version from CRAN, run and store examples\n",
"- dev: install dev version from current directory, run and store examples\n",
"- compare: stored results of both versions")
}
#' Script for running scheduled test
#'
#' All files with the pattern /testthat/tests/scheduled-*.R are tested
#' as testthat does for files /testthat/tests/test-*.R.
#'
#' This script should be started with `source` command from the root of the package.
#' @example
#' source("tests/scheduled.R")
####################
# Helper functions #
####################
#' Wrapper for [quit] which is only applied outside of RStudio
#'
#' @param status See `status` parameter of [quit]. Default `quit = 1`.
#' @param ... Other parameters sent to [quit]
#'
#' @return NULL
#' @export
quit2 <- function(status = 1, ...) {
if (all(!grepl("rstudio", Sys.getenv(), ignore.case = TRUE))) {
quit(status, ...)
}
}
###############
# MAIN SCRIPT #
###############
library(testthat)
library(airGR)
scheduled_tests <- list.files(
path = "tests/testthat",
pattern = "^scheduled-.*\\.R$",
full.names = TRUE
)
lRes <- lapply(scheduled_tests, test_file)
for (res in lRes) {
dRes <- as.data.frame(res)
if (any(dRes[, "failed"] > 0) | any(dRes[, "error"])) {
quit2()
}
}
# Execute Regression test by comparing RD files stored in folders /tests/tmp/ref and /tests/tmp/test
Args <- commandArgs(trailingOnly = TRUE)
source("tests/testthat/helper_regression.R")
lActions <- list(
stable = StoreStableExampleResults,
dev = StoreDevExampleResults,
compare = CompareStableDev
)
if(Args %in% names(lActions)) {
lActions[[Args]]()
} else {
stop("This script should be run with one argument in the command line:\n",
"`Rscript tests/regression_tests.R [stable|dev|compare]`.\n",
"Available arguments are:\n",
"- stable: install stable version from CRAN, run and store examples\n",
"- dev: install dev version from current directory, run and store examples\n",
"- compare: stored results of both versions")
}
context("Calibration")
sModels <- c(
"name IsHyst data aggreg ParamFinalR",
"GR1A FALSE L0123001 %Y 0.91125",
"GR2M FALSE L0123001 %Y%m 259.8228;0.9975",
"GR4J FALSE L0123001 NA 223.6315877;0.5781516;97.5143942;2.2177177",
"GR5J FALSE L0123001 NA 220.3863609;0.8944531;93.5640705;1.7628720;0.4846427",
"GR6J FALSE L0123001 NA 192.8761657;0.6933087;49.1783293;2.2145422;0.5088240;6.8146261",
"CemaNeigeGR4J FALSE L0123001 NA 2.043839e+02;5.781516e-01;1.025141e+02;2.217718e+00;1.501502e-03;1.432036e+01",
"CemaNeigeGR5J FALSE L0123001 NA 1.983434e+02;8.747758e-01;9.849443e+01;1.768769e+00;4.829830e-01;1.501502e-03;1.432036e+01",
"CemaNeigeGR6J FALSE L0123001 NA 184.9341841;0.5551637;59.7398917;2.2177177;0.4760000;6.0496475;0.0000000;14.4642868",
"CemaNeigeGR4J TRUE L0123001 NA 208.5127103;0.5781516;102.5140641;2.2274775;0.0000000;6.7644613;8.0000000;1.0000000",
"CemaNeigeGR5J TRUE L0123001 NA 202.350228;0.901525;98.494430;1.788288;0.483984;0.000000;7.401500;6.100000;1.000000",
"CemaNeigeGR6J TRUE L0123001 NA 188.67010241;0.56662930;60.34028760;2.22747748;0.47600000;5.98945247;0.03203203;7.93816892;10.80000000;1.00000000",
"GR4H FALSE L0123003 NA 711.676649;-1.158469;150.556095;4.686093",
"GR5H FALSE L0123003 NA 804.0021672;-0.1898488;137.7524699;3.0436628;0.1951163",
"CemaNeigeGR4H FALSE L0123003 NA 1.595685e+03;-8.183484e-01;2.320697e+02;5.000000e-01;5.005005e-04;9.342369e+01",
"CemaNeigeGR5H FALSE L0123003 NA 33.34921883;-4.98925432;332.00673122;1.58534106;0.20792716;0.02214393;4.28498513",
"CemaNeigeGR4H TRUE L0123003 NA 1.766316e+03;-6.920667e-01;2.192034e+02;3.451688e+00;5.005005e-04;4.869585e+01;1.111447e+01;5.064090e-01",
"CemaNeigeGR5H TRUE L0123003 NA 66.6863310;-1.4558128;138.3795123;2.6499450;0.2325000;0.0000000;0.3017014;48.4000000;0.9914915"
)
dfModels <- read.table(text = paste(sModels, collapse = "\n"), header = TRUE)
ModelCalibration <- function(model) {
sModel <- paste0("RunModel_", model$name)
sIM_FUN_MOD <- sModel
if(model$data == "L0123003") {
# hourly time step database
dates <- c("2004-01-01 00:00", "2004-12-31 23:00", "2005-01-01 00:00", "2008-12-31 23:00")
date_format = "%Y-%m-%d %H:%M"
TempMean <- fakeHourlyTemp()
} else {
# yearly, monthly, daily time step databases
dates <- c("1985-01-01", "1985-12-31", "1986-01-01", "2012-12-31")
date_format <- "%Y-%m-%d"
if(!is.na(model$aggreg)) {
# Aggregation on monthly and yearly databases
sIM_FUN_MOD <- "RunModel_GR4J" # CreateInputsModel with daily data
date_format <- model$aggreg
}
}
## loading catchment data
data(list = model$data)
if(model$data != "L0123003") TempMean <- BasinObs$T
# preparation of the InputsModel object
InputsModel <- CreateInputsModel(FUN_MOD = sIM_FUN_MOD,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E,
TempMean = TempMean,
ZInputs = median(BasinInfo$HypsoData),
HypsoData = BasinInfo$HypsoData,
NLayers = 5)
if(!is.na(model$aggreg)) {
# conversion of InputsModel to target time step
InputsModel <- SeriesAggreg(InputsModel, Format = model$aggreg)
dfQobs <- SeriesAggreg(data.frame(DatesR = BasinObs$DatesR, Qmm = BasinObs$Qmm),
Format = model$aggreg, ConvertFun = "sum")
Obs <- dfQobs$Qmm
} else {
Obs <- BasinObs$Qmm
}
# calibration period selection
dates <- sapply(dates, function(x) format(as.Date(x), format = date_format))
Ind_WarmUp <- seq(
which(format(InputsModel$DatesR, format = date_format)==dates[1]),
which(format(InputsModel$DatesR, format = date_format)==dates[2])
)
Ind_Run <- seq(
which(format(InputsModel$DatesR, format = date_format)==dates[3]),
which(format(InputsModel$DatesR, format = date_format)==dates[4])
)
# preparation of the RunOptions object
suppressWarnings(
RunOptions <- CreateRunOptions(
FUN_MOD = sModel,
InputsModel = InputsModel,
IndPeriod_Run = Ind_Run,
IndPeriod_WarmUp = Ind_WarmUp,
IsHyst = as.logical(model$IsHyst)
)
)
# calibration criterion: preparation of the InputsCrit object
InputsCrit <- CreateInputsCrit(FUN_CRIT = ErrorCrit_NSE, InputsModel = InputsModel,
RunOptions = RunOptions, Obs = Obs[Ind_Run])
# preparation of CalibOptions object
CalibOptions <- CreateCalibOptions(sModel, IsHyst = as.logical(model$IsHyst))
# calibration
suppressWarnings(OutputsCalib <- Calibration(InputsModel = InputsModel, RunOptions = RunOptions,
InputsCrit = InputsCrit, CalibOptions = CalibOptions,
FUN_MOD = sModel))
OutputsCalib$ParamFinalR
}
TestModelCalibration <- function(model) {
model <- as.list(model)
test_that(paste(model$name, ifelse(as.logical(model$IsHyst), "Hysteresis", ""), "works"), {
ParamFinalR <- ModelCalibration(model)
expect_equal(ParamFinalR,
as.numeric(strsplit(model$ParamFinalR, ";")[[1]]),
tolerance = 1E-6)
})
}
#' Create Fake hourly temperature from daily temperatures in L0123001
#'
#' @param start_date [character] start date in format "%Y-%m-%d"
#' @param end_date [character] end date in format "%Y-%m-%d"
#' @return [numeric] hourly temperature time series between `start_date` and `end_date`
fakeHourlyTemp <- function(start_date = "2004-01-01", end_date = "2008-12-31") {
dates <- as.POSIXct(c(start_date, end_date), tz = "UTC")
data(L0123002)
indJ <- seq.int(which(BasinObs$DatesR == as.POSIXct(dates[1])),
which(BasinObs$DatesR == as.POSIXct(dates[2])))
TJ <- BasinObs$T[indJ]
TH <- approx((seq.int(length(TJ)) - 1) * 24,TJ,
seq.int(length(TJ) * 24 ) - 1,
rule = 2)$y
varT_1J <- -sin(0:23/24 * 2 * pi) # Temp min at 6 and max at 18
varT <- rep(varT_1J, length(TJ))
TH <- TH + varT * 5 # For a mean daily amplitude of 10°
TH
}
apply(dfModels, 1, TestModelCalibration)
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