From 1ff328ac2a495904dd531cd42301ff4e0e41b210 Mon Sep 17 00:00:00 2001
From: Dorchies David <david.dorchies@inrae.fr>
Date: Fri, 9 Jul 2021 19:21:30 +0200
Subject: [PATCH] fix(CreateIniStates): crash with
CreateIniStates(RunModel_Lag, ...)
- Use .GetFeatModel for having always up to date function list
Refs #132
---
R/CreateIniStates.R | 72 +++++++--------------------
tests/testthat/test-CreateiniStates.R | 6 +++
2 files changed, 25 insertions(+), 53 deletions(-)
diff --git a/R/CreateIniStates.R b/R/CreateIniStates.R
index 9fe48b13..84e6b53c 100644
--- a/R/CreateIniStates.R
+++ b/R/CreateIniStates.R
@@ -12,45 +12,11 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
UH1n <- 20L
UH2n <- UH1n * 2L
- nameFUN_MOD <- as.character(substitute(FUN_MOD))
FUN_MOD <- match.fun(FUN_MOD)
- ## check FUN_MOD
- BOOL <- FALSE
- if (identical(FUN_MOD, RunModel_GR4H) | identical(FUN_MOD, RunModel_GR5H)) {
- ObjectClass <- c(ObjectClass, "GR", "hourly")
- BOOL <- TRUE
- }
- if (identical(FUN_MOD, RunModel_GR4J) |
- identical(FUN_MOD, RunModel_GR5J) |
- identical(FUN_MOD, RunModel_GR6J)) {
- ObjectClass <- c(ObjectClass, "GR", "daily")
- BOOL <- TRUE
- }
- if (identical(FUN_MOD, RunModel_GR2M)) {
- ObjectClass <- c(ObjectClass, "GR", "monthly")
- BOOL <- TRUE
- }
- if (identical(FUN_MOD, RunModel_GR1A)) {
- stop("'RunModel_GR1A' does not require 'IniStates' object")
- }
- if (identical(FUN_MOD, RunModel_CemaNeige)) {
- ObjectClass <- c(ObjectClass, "CemaNeige", "daily")
- BOOL <- TRUE
- }
- if (identical(FUN_MOD, RunModel_CemaNeigeGR4H) | identical(FUN_MOD, RunModel_CemaNeigeGR5H)) {
- ObjectClass <- c(ObjectClass, "GR", "CemaNeige", "hourly")
- BOOL <- TRUE
- }
- if (identical(FUN_MOD, RunModel_CemaNeigeGR4J) |
- identical(FUN_MOD, RunModel_CemaNeigeGR5J) |
- identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
- ObjectClass <- c(ObjectClass, "GR", "CemaNeige", "daily")
- BOOL <- TRUE
- }
- if (!BOOL) {
- stop("incorrect 'FUN_MOD' for use in 'CreateIniStates'")
- }
+ FeatFUN_MOD <- .GetFeatModel(FUN_MOD = FUN_MOD, DatesR = InputsModel$DatesR)
+ ObjectClass <- FeatFUN_MOD$Class
+
if (!"CemaNeige" %in% ObjectClass & IsHyst) {
stop("'IsHyst' cannot be TRUE if CemaNeige is not used in 'FUN_MOD'")
}
@@ -82,7 +48,7 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
}
} else if (!is.null(ExpStore)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'ExpStore'. Value set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'ExpStore'. Value set to NA", FeatFUN_MOD$NameFunMod))
}
ExpStore <- Inf
}
@@ -90,13 +56,13 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
if (identical(FUN_MOD, RunModel_GR2M)) {
if (!is.null(UH1)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'UH1'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'UH1'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
UH1 <- rep(Inf, UH1n)
}
if (!is.null(UH2)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'UH2'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'UH2'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
UH2 <- rep(Inf, UH2n)
}
@@ -104,13 +70,13 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
if ((identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J)) & !is.null(UH1)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'UH1'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'UH1'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
UH1 <- rep(Inf, UH1n)
}
if ((!identical(FUN_MOD, RunModel_GR5H) | identical(FUN_MOD, RunModel_CemaNeigeGR5H)) & !is.null(IntStore)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'IntStore'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'IntStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
IntStore <- Inf
}
@@ -118,57 +84,57 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
if ("CemaNeige" %in% ObjectClass & ! "GR" %in% ObjectClass) {
if (!is.null(ProdStore)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'ProdStore'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'ProdStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
ProdStore <- Inf
if (!is.null(RoutStore)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'RoutStore'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'RoutStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
RoutStore <- Inf
if (!is.null(ExpStore)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'ExpStore'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'ExpStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
ExpStore <- Inf
if (!is.null(IntStore)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'IntStore'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'IntStore'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
IntStore <- Inf
if (!is.null(UH1)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'UH1'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'UH1'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
UH1 <- rep(Inf, UH1n)
if (!is.null(UH2)) {
if (verbose) {
- warning(sprintf("'%s' does not require 'UH2'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'UH2'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
}
UH2 <- rep(Inf, UH2n)
}
if (IsIntStore & is.null(IntStore)) {
- stop(sprintf("'%s' need values for 'IntStore'", nameFUN_MOD))
+ stop(sprintf("'%s' need values for 'IntStore'", FeatFUN_MOD$NameFunMod))
}
if ("CemaNeige" %in% ObjectClass & !IsHyst &
(is.null(GCemaNeigeLayers) | is.null(eTGCemaNeigeLayers))) {
- stop(sprintf("'%s' need values for 'GCemaNeigeLayers' and 'GCemaNeigeLayers'", nameFUN_MOD))
+ stop(sprintf("'%s' need values for 'GCemaNeigeLayers' and 'GCemaNeigeLayers'", FeatFUN_MOD$NameFunMod))
}
if ("CemaNeige" %in% ObjectClass & IsHyst &
(is.null(GCemaNeigeLayers) | is.null(eTGCemaNeigeLayers) |
is.null(GthrCemaNeigeLayers) | is.null(GlocmaxCemaNeigeLayers))) {
- stop(sprintf("'%s' need values for 'GCemaNeigeLayers', 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'", nameFUN_MOD))
+ stop(sprintf("'%s' need values for 'GCemaNeigeLayers', 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'", FeatFUN_MOD$NameFunMod))
}
if ("CemaNeige" %in% ObjectClass & !IsHyst &
(!is.null(GthrCemaNeigeLayers) | !is.null(GlocmaxCemaNeigeLayers))) {
if (verbose) {
- warning(sprintf("'%s' does not require 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
GthrCemaNeigeLayers <- Inf
GlocmaxCemaNeigeLayers <- Inf
@@ -176,7 +142,7 @@ CreateIniStates <- function(FUN_MOD, InputsModel, IsHyst = FALSE, IsIntStore = F
if (!"CemaNeige" %in% ObjectClass &
(!is.null(GCemaNeigeLayers) | !is.null(eTGCemaNeigeLayers) | !is.null(GthrCemaNeigeLayers) | !is.null(GlocmaxCemaNeigeLayers))) {
if (verbose) {
- warning(sprintf("'%s' does not require 'GCemaNeigeLayers' 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA", nameFUN_MOD))
+ warning(sprintf("'%s' does not require 'GCemaNeigeLayers' 'GCemaNeigeLayers', 'GthrCemaNeigeLayers' and 'GlocmaxCemaNeigeLayers'. Values set to NA", FeatFUN_MOD$NameFunMod))
}
GCemaNeigeLayers <- Inf
eTGCemaNeigeLayers <- Inf
diff --git a/tests/testthat/test-CreateiniStates.R b/tests/testthat/test-CreateiniStates.R
index 17ac824b..3f1cb1c6 100644
--- a/tests/testthat/test-CreateiniStates.R
+++ b/tests/testthat/test-CreateiniStates.R
@@ -96,3 +96,9 @@ test_that("Error: Number of items not equal to number of upstream connections",
)
})
})
+
+test_that("FUN = RunModel_lag must work", {
+ IS <- CreateIniStates(RunModel_Lag, InputsModel, SD = list(rep(0, 10)))
+ expect_equal(IS$SD[[1]], rep(0, 10))
+ expect_s3_class(IS, "SD")
+})
--
GitLab