From 0967defbb0e3e4669231dd6b488377f4869d3d31 Mon Sep 17 00:00:00 2001
From: Delaigue Olivier <olivier.delaigue@irstea.priv>
Date: Thu, 2 May 2019 13:51:36 +0200
Subject: [PATCH] v1.2.14.17 UPDATE: CreateInputsCrit returns FUN_CRIT as
character string
---
DESCRIPTION | 2 +-
NEWS.rmd | 2 +-
R/CreateInputsCrit.R | 7 +++++++
R/ErrorCrit.R | 20 +++++++++++---------
4 files changed, 20 insertions(+), 11 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 703fc55f..5e11a483 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.2.14.16
+Version: 1.2.14.17
Date: 2019-05-02
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
diff --git a/NEWS.rmd b/NEWS.rmd
index 53db83b4..46667a84 100644
--- a/NEWS.rmd
+++ b/NEWS.rmd
@@ -14,7 +14,7 @@ output:
-### 1.2.14.16 Release Notes (2019-05-02)
+### 1.2.14.17 Release Notes (2019-05-02)
#### New features
diff --git a/R/CreateInputsCrit.R b/R/CreateInputsCrit.R
index 365679f9..ae64a8d6 100644
--- a/R/CreateInputsCrit.R
+++ b/R/CreateInputsCrit.R
@@ -267,6 +267,7 @@ CreateInputsCrit <- function(FUN_CRIT,
}
}
+
## Create InputsCrit
iInputsCrit <- list(FUN_CRIT = iListArgs2$FUN_CRIT,
Obs = iListArgs2$Obs,
@@ -282,6 +283,12 @@ CreateInputsCrit <- function(FUN_CRIT,
})
names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
+ ## define FUN_CRIT as a characater string
+ listErrorCrit <- c("ErrorCrit_KGE", "ErrorCrit_KGE2", "ErrorCrit_NSE", "ErrorCrit_RMSE")
+ InputsCrit <- lapply(InputsCrit, function(i) {
+ i$FUN_CRIT <- listErrorCrit[sapply(listErrorCrit, function(j) identical(i$FUN_CRIT, get(j)))]
+ i
+ })
listVarObs <- sapply(InputsCrit, FUN = "[[", "VarObs")
inCnVarObs <- c("SCA", "SWE")
diff --git a/R/ErrorCrit.R b/R/ErrorCrit.R
index 53f65119..28e9368a 100644
--- a/R/ErrorCrit.R
+++ b/R/ErrorCrit.R
@@ -19,10 +19,11 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
## ----- Single criterion
if (inherits(InputsCrit, "Single")) {
- OutputsCrit <- InputsCrit$FUN_CRIT(InputsCrit = InputsCrit,
- OutputsModel = OutputsModel,
- warnings = warnings,
- verbose = verbose)
+ FUN_CRIT <- match.fun(InputsCrit$FUN_CRIT)
+ OutputsCrit <- FUN_CRIT(InputsCrit = InputsCrit,
+ OutputsModel = OutputsModel,
+ warnings = warnings,
+ verbose = verbose)
}
@@ -30,10 +31,11 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
if (inherits(InputsCrit, "Multi") | inherits(InputsCrit, "Compo")) {
listOutputsCrit <- lapply(InputsCrit, FUN = function(iInputsCrit) {
- iInputsCrit$FUN_CRIT(InputsCrit = iInputsCrit,
- OutputsModel = OutputsModel,
- warnings = warnings,
- verbose = verbose)
+ FUN_CRIT <- match.fun(iInputsCrit$FUN_CRIT)
+ FUN_CRIT(InputsCrit = iInputsCrit,
+ OutputsModel = OutputsModel,
+ warnings = warnings,
+ verbose = verbose)
})
listValCrit <- sapply(listOutputsCrit, function(x) x[["CritValue"]])
@@ -70,7 +72,7 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
}
}
-
+
return(OutputsCrit)
}
--
GitLab