diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R
index 5eb509c86f0633055e50999e8c54c26a8b74449a..6e0cdd38f9cd53dd4f0f5afa52c9b9d2233465c8 100644
--- a/R/Calibration.GRiwrmInputsModel.R
+++ b/R/Calibration.GRiwrmInputsModel.R
@@ -48,6 +48,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
l <- updateParameters4Ungauged(id,
InputsModel,
RunOptions,
+ CalibOptions,
OutputsModel,
useUpstreamQsim)
IM <- l$InputsModel
@@ -84,14 +85,24 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
subBasinAreas <- calcSubBasinAreas(IM)
}
for (uId in Ids) {
- # Add OutputsCalib for ungauged nodes
- OutputsCalib[[uId]] <- OutputsCalib[[id]]
- # Copy parameters and transform X4 relatively to the sub-basin area
- OutputsCalib[[uId]]$ParamFinalR <-
- OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged]
- if(IM[[id]]$model$hasX4) {
- OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <-
- X4 * (subBasinAreas[uId] / sum(subBasinAreas)) ^ 0.3
+ if(!IM[[uId]]$isReservoir) {
+ # Add OutputsCalib for ungauged nodes
+ OutputsCalib[[uId]] <- OutputsCalib[[id]]
+ # Copy parameters and transform X4 relatively to the sub-basin area
+ OutputsCalib[[uId]]$ParamFinalR <-
+ OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged]
+ if(IM[[id]]$model$hasX4) {
+ OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <-
+ X4 * (subBasinAreas[uId] / sum(subBasinAreas, na.rm = TRUE)) ^ 0.3
+ }
+ } else {
+ OutputsCalib[[uId]] <- Calibration(
+ InputsModel = IM[[uId]],
+ RunOptions = RunOptions[[uId]],
+ InputsCrit = IC,
+ CalibOptions = CalibOptions[[uId]],
+ ...
+ )
}
}
IM <- IM[[id]]
@@ -168,16 +179,30 @@ reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
return(obj)
}
+
+#' Set a reduced GRiwrm network for calibration of a sub-network with ungauged
+#' hydrological nodes
+#'
+#' @inheritParams Calibration
+#' @param GaugedId [character] Id of the gauged node
+#' @param OutputsModel *GRiwrmOutputsModel* of the complete network
+#'
+#' @return A [list] containing the following items:
+#' - `InputsModel`: a *GRiwrmInputsModel* of the reduced network
+#' - `RunOptions`: a *GRiwrmRunOptions* of the reduced network
+#' @noRd
+#'
updateParameters4Ungauged <- function(GaugedId,
InputsModel,
RunOptions,
+ CalibOptions,
OutputsModel,
useUpstreamQsim) {
### Set the reduced network of the basin containing ungauged nodes ###
- # Select nodes identified with the current node as gauged node
+ # Select nodes identified with the current node as donor gauged node
griwrm <- attr(InputsModel, "GRiwrm")
- gDonor <- griwrm[griwrm$donor == GaugedId, ]
+ gDonor <- griwrm[!is.na(griwrm$donor) & griwrm$donor == GaugedId, ]
# Add upstream nodes for routing upstream flows
upIds <- griwrm$id[griwrm$down %in% gDonor$id & !griwrm$id %in% gDonor$id]
g <- rbind(griwrm[griwrm$id %in% upIds, ], gDonor)
@@ -188,9 +213,15 @@ updateParameters4Ungauged <- function(GaugedId,
### Modify InputsModel for the reduced network ###
# Remove nodes outside of reduced network
InputsModel <- reduceGRiwrmObj4Ungauged(g, InputsModel)
+ # Copy fixed parameters for Reservoirs
+ for (id in names(InputsModel)) {
+ if (InputsModel[[id]]$isReservoir) {
+ InputsModel[[id]]$FixedParam <- CalibOptions[[id]]$FixedParam
+ }
+ }
# Update griwrm
attr(InputsModel, "GRiwrm") <- g
- # Update Qupstream already modelled in the reduced network upstream nodes
+ # Update Qupstream already modeled in the reduced network upstream nodes
idIM <- unique(g$down[g$id %in% upIds])
for (id in idIM) {
if(useUpstreamQsim && any(InputsModel[[id]]$UpstreamIsModeled)) {
@@ -258,9 +289,12 @@ calcSubBasinAreas <- function(IM) {
#' @noRd
RunModel_Ungauged <- function(InputsModel, RunOptions, Param) {
InputsModel$FUN_MOD <- NULL
- SBVI <- sum(calcSubBasinAreas(InputsModel))
+ SBVI <- sum(calcSubBasinAreas(InputsModel), na.rm = TRUE)
# Compute Param for each sub-basin
P <- lapply(InputsModel, function(IM) {
+ if (IM$isReservoir) {
+ return(IM$FixedParam)
+ }
p <- Param[IM$model$indexParamUngauged]
if(IM$model$hasX4) {
p[IM$model$iX4] <- Param[IM$model$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / SBVI) ^ 0.3
diff --git a/R/CreateCalibOptions.GRiwrmInputsModel.R b/R/CreateCalibOptions.GRiwrmInputsModel.R
index d6b23461d000b060677585e58af5b7216cfd0a79..db82761baf5a74264e820d54cb20d30e8c70a907 100644
--- a/R/CreateCalibOptions.GRiwrmInputsModel.R
+++ b/R/CreateCalibOptions.GRiwrmInputsModel.R
@@ -6,7 +6,7 @@ CreateCalibOptions.GRiwrmInputsModel <- function(x, ...) {
class(CalibOptions) <- c("GRiwrmCalibOptions", class(CalibOptions))
np <- getAllNodesProperties(attr(x, "GRiwrm"))
- gaugedIds <- np$id[np$hydrology == "Gauged"]
+ gaugedIds <- np$id[np$calibration == "Gauged"]
for(id in gaugedIds) {
IM <- x[[id]]
CalibOptions[[IM$id]] <- CreateCalibOptions(
diff --git a/R/CreateGRiwrm.R b/R/CreateGRiwrm.R
index 4bb096fb682c7d615738a210bfe29f6c8d41f6ff..fe5e93fc366b98624b6216368ddf899e1ec56d29 100644
--- a/R/CreateGRiwrm.R
+++ b/R/CreateGRiwrm.R
@@ -85,8 +85,8 @@ CreateGRiwrm <- function(db,
area = "double"),
keep_all)
checkNetworkConsistency(griwrm)
- griwrm$donor <- sapply(griwrm$id, getGaugedId, griwrm = griwrm)
class(griwrm) <- c("GRiwrm", class(griwrm))
+ griwrm$donor <- setDonor(griwrm)
griwrm
}
@@ -176,11 +176,6 @@ checkNetworkConsistency <- function(db) {
nodeError(db[i, ],
"A Diversion node must have the same `id` of one (and only one) node with a model")
}
- if (length(unique(db$down[db$id == x])) != 2) {
- nodeError(db[i, ], paste(
- "The downstream node of a Diversion node must be different",
- "than the downstream node of the node is attached to"))
- }
})
id_reservoirs <- db3$id[db3$model == "RunModel_Reservoir"]
sapply(id_reservoirs, function(id) {
@@ -230,19 +225,24 @@ nodeError <- function(node, s) {
#' @param id [character] Id of the current node
#' @param griwrm See [CreateGRiwrm])
#'
-#' @return [character] Id of the first node with a model
+#' @return [character] Id of the first node with a model of `FALSE` if not found
#'
#' @noRd
getGaugedId <- function(id, griwrm) {
- griwrm <- griwrm[getDiversionRows(griwrm, TRUE), ]
- if (!is.na(griwrm$model[griwrm$id == id]) &
- griwrm$model[griwrm$id == id] != "Ungauged") {
+ np <- getNodeProperties(id, griwrm)
+ if (np$RunOff && np$calibration == "Gauged") {
+ # Match with au gauged station!
return(id)
- } else if (!is.na(griwrm$down[griwrm$id == id])) {
- return(getGaugedId(griwrm$down[griwrm$id == id], griwrm))
} else {
- stop("The model of the downstream node of a network",
- " cannot be `NA` or \"Ungauged\"")
+ # Otherwise we need to search downstream on the natural network
+ g2 <- griwrm[getDiversionRows(griwrm, TRUE), ]
+ id_down <- g2$down[g2$id == id]
+ if (!is.na(id_down)) {
+ return(getGaugedId(id_down, griwrm))
+ } else {
+ #If we already are at the downstream end, we have a problem...
+ return(FALSE)
+ }
}
}
@@ -258,3 +258,24 @@ getDiversionRows <- function(griwrm, inverse = FALSE) {
}
return(rows)
}
+
+setDonor <- function(griwrm) {
+ sapply(seq(nrow(griwrm)), function(i) {
+ id <- griwrm$id[i]
+ model <- griwrm$model[i]
+ if (is.na(model) || model == "Diversion") {
+ # Diversion and Direct injection are "Non Applicable"
+ return(NA)
+ } else if(model == "RunModel_Reservoir" && is.na(griwrm$down[i])){
+ # RunModel_Reservoir needs to be its own "donor" only if at downstream
+ # Otherwise we search the first gauged station downstream to allow
+ # calibration with ungauged upstream nodes
+ return(id)
+ }
+ gaugedId <- getGaugedId(id, griwrm = griwrm)
+ if (gaugedId == FALSE) {
+ stop("No Gauged node found downstream the node '", id, "'")
+ }
+ return(gaugedId)
+ })
+}
diff --git a/R/CreateInputsCrit.GRiwrmInputsModel.R b/R/CreateInputsCrit.GRiwrmInputsModel.R
index 4bc582f338d7fcc576e2bf6b9ec2008d4dce17c9..f78a11c5105eb34c5ba3e4a3f12485386f3163eb 100644
--- a/R/CreateInputsCrit.GRiwrmInputsModel.R
+++ b/R/CreateInputsCrit.GRiwrmInputsModel.R
@@ -73,7 +73,7 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
class(InputsCrit) <- append("GRiwrmInputsCrit", class(InputsCrit))
np <- getAllNodesProperties(attr(InputsModel, "GRiwrm"))
- gaugedIds <- np$id[np$hydrology == "Gauged"]
+ gaugedIds <- np$id[np$calibration == "Gauged"]
for(id in gaugedIds) {
if (id %in% colnames(Obs)) {
IM <- InputsModel[[id]]
diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R
index 2ef3a66d27032e4368946a7a6a1b0ca824bcd08b..927862e874d466219859d60204c75b7c9e0bad2a 100644
--- a/R/CreateInputsModel.GRiwrm.R
+++ b/R/CreateInputsModel.GRiwrm.R
@@ -230,7 +230,7 @@ CreateEmptyGRiwrmInputsModel <- function(griwrm) {
InputsModel <- list()
class(InputsModel) <- c("GRiwrmInputsModel", class(InputsModel))
# Update griwrm in case of manual change in model column
- griwrm$donor <- sapply(griwrm$id, getGaugedId, griwrm = griwrm)
+ griwrm$donor <- setDonor(griwrm)
attr(InputsModel, "GRiwrm") <- griwrm
return(InputsModel)
}
@@ -249,14 +249,17 @@ CreateEmptyGRiwrmInputsModel <- function(griwrm) {
#' @return \emph{InputsModel} object for one.
#' @noRd
CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
- hasDiversion <- getNodeProperties(id, griwrm)$Diversion
- if (hasDiversion) {
+ np <- getNodeProperties(id, griwrm)
+
+ if (np$Diversion) {
rowDiv <- which(griwrm$id == id & griwrm$model == "Diversion")
diversionOutlet <- griwrm$down[rowDiv]
griwrm <- griwrm[-rowDiv, ]
}
node <- griwrm[griwrm$id == id,]
- FUN_MOD <- griwrm$model[griwrm$id == griwrm$donor[griwrm$id == id]]
+
+ g2 <- griwrm[getDiversionRows(griwrm, TRUE), ]
+ FUN_MOD <- g2$model[g2$id == g2$donor[g2$id == id]]
# Set hydraulic parameters
UpstreamNodeRows <- which(griwrm$down == id & !is.na(griwrm$down))
@@ -293,11 +296,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
names(BasinAreas) <- c(griwrm$id[UpstreamNodeRows], id)
}
- if (identical(match.fun(FUN_MOD), RunModel_Reservoir)) {
- isReservoir <- TRUE
+ if (np$Reservoir) {
FUN_MOD <- "RunModel_Lag"
- } else {
- isReservoir <- FALSE
}
# Set model inputs with the **airGR** function
InputsModel <- CreateInputsModel(
@@ -337,15 +337,17 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
hasX4 = grepl("RunModel_GR[456][HJ]", FUN_MOD),
iX4 = ifelse(inherits(InputsModel, "SD"), 5, 4)
)
- InputsModel$hasDiversion <- hasDiversion
- InputsModel$isReservoir <- isReservoir
+ InputsModel$hasDiversion <- np$Diversion
+ InputsModel$isReservoir <- np$Reservoir
# Add specific properties for Diversion and Reservoir nodes
- if (hasDiversion) {
+ if (np$Diversion) {
InputsModel$diversionOutlet <- diversionOutlet
InputsModel$Qdiv <- -Qobs[, id]
InputsModel$Qmin <- Qmin
- } else if(isReservoir) {
+ } else if(np$Reservoir) {
+ # If an upstream node is ungauged then we are in an ungauged reduced network
+ InputsModel$isUngauged <- any(griwrm$model[UpstreamNodeRows] == "Ungauged")
InputsModel$Qrelease <- Qobs[, id]
}
return(InputsModel)
@@ -419,6 +421,7 @@ getInputBV <- function(x, id, unset = NULL) {
#'
#' @noRd
hasUngaugedNodes <- function(id, griwrm) {
+ nps <- getAllNodesProperties(griwrm)
upIds <- griwrm$id[griwrm$down == id]
upIds <- upIds[!is.na(upIds)]
# No upstream nodes
@@ -427,11 +430,13 @@ hasUngaugedNodes <- function(id, griwrm) {
UngNodes <- griwrm$model[griwrm$id %in% upIds] == "Ungauged"
UngNodes <- UngNodes[!is.na(UngNodes)]
if(length(UngNodes) > 0 && any(UngNodes)) return(TRUE)
- # At least one node's model is NA need to investigate next level
- if(any(is.na(griwrm$model[griwrm$id %in% upIds]))) {
- g <- griwrm[griwrm$id %in% upIds, ]
- NaIds <- g$id[is.na(g$model)]
- out <- sapply(NaIds, hasUngaugedNodes, griwrm = griwrm)
+
+ upNps <- nps[nps$id %in% upIds, ]
+ if(any(upNps$DirectInjection) || any(upNps$Reservoir)) {
+ # At least one node's model is NA or Reservoir, we need to investigate next level
+ out <- sapply(upNps$id[upNps$DirectInjection | upNps$Reservoir],
+ hasUngaugedNodes,
+ griwrm = griwrm)
return(any(out))
}
return(FALSE)
diff --git a/R/getNodeProperties.R b/R/getNodeProperties.R
index b2d751efad58bc35d888b0244a8e64743330d7b2..8a6e6509a32ef14f261bf7ef033580b2dec45c3e 100644
--- a/R/getNodeProperties.R
+++ b/R/getNodeProperties.R
@@ -5,8 +5,8 @@
#'
#' @return A [list] with the following items:
#' - "position" ([character]): Position of the node in the network ("Upstream" or "Intermediate")
-#' - "hydrology" ([character]): describe if the node is a "Gauged" or an "Ungauged" station
-#' modelled with an hydrological model, or a "DirectionInjection" node
+#' - "calibration" ([character]): describe if the node is a "Gauged", or an "Ungauged" station,
+#' modelled with an hydrological model, or "NA" otherwise
#' - "Upstream" ([logical]): is the node an upstream node?
#' - "DirectInjection" ([logical]): is the node a Direct Injection node?
#' - "Diversion" ([logical]): is the node a Diversion node?
@@ -16,21 +16,24 @@
#' @example man-examples/getNodeProperties.R
getNodeProperties <- function(id, griwrm) {
stopifnot(inherits(griwrm, "GRiwrm"))
- g_div <- griwrm[getDiversionRows(griwrm), , drop = FALSE]
g2 <- griwrm[getDiversionRows(griwrm, TRUE), , drop = FALSE]
upstreamIds <- griwrm$id[!griwrm$id %in% griwrm$down]
- gaugedIds <- g2$id[!is.na(g2$model) & !g2$model %in% c("Ungauged")]
- divertedIds <- g_div$id
+ model <- g2$model[g2$id == id]
p <- list(
position = ifelse(id %in% upstreamIds, "Upstream", "Intermediate"),
- hydrology = ifelse(id %in% gaugedIds, "Gauged",
- ifelse(is.na(g2$model[g2$id == id]), "NA", "Ungauged")),
- DirectInjection = is.na(g2$model[g2$id == id]),
- Diversion = id %in% divertedIds,
- Reservoir = !is.na(g2$model[g2$id == id]) && g2$model[g2$id == id] == "RunModel_Reservoir"
+ DirectInjection = is.na(model),
+ Diversion = "Diversion" %in% griwrm$model[griwrm$id == id],
+ Reservoir = !is.na(model) && model == "RunModel_Reservoir"
)
+ if (p$DirectInjection) {
+ p$calibration <- "NA"
+ } else if (model == "Ungauged") {
+ p$calibration <- "Ungauged"
+ } else {
+ p$calibration <- "Gauged"
+ }
p$Upstream <- p$position == "Upstream"
- p$RunOff <- p$hydrology != "NA" & !p$Reservoir
+ p$RunOff <- !p$DirectInjection && !p$Reservoir
return(p)
}
diff --git a/R/plot.GRiwrm.R b/R/plot.GRiwrm.R
index fdfa7a41069ede5bcb807f7c63c1f88d5c6fc694..cddb2f90ac08552773ada031ebf6caa0eb605709 100644
--- a/R/plot.GRiwrm.R
+++ b/R/plot.GRiwrm.R
@@ -91,7 +91,7 @@ getNodeClass <- function(id, griwrm) {
} else if (props$Reservoir) {
nc <- "Reservoir"
} else {
- nc <- paste0(props["position"], props["hydrology"])
+ nc <- paste0(props$position, props$calibration)
}
if (props$Diversion) nc <- paste0(nc, "Diversion")
return(nc)
diff --git a/man/getNodeProperties.Rd b/man/getNodeProperties.Rd
index 23c38ae472fd9363474db925bd591e73054f60b1..b8f1126ec6cf0424ba5b100148899e5fd92bea88 100644
--- a/man/getNodeProperties.Rd
+++ b/man/getNodeProperties.Rd
@@ -15,8 +15,8 @@ getNodeProperties(id, griwrm)
A \link{list} with the following items:
\itemize{
\item "position" (\link{character}): Position of the node in the network ("Upstream" or "Intermediate")
-\item "hydrology" (\link{character}): describe if the node is a "Gauged" or an "Ungauged" station
-modelled with an hydrological model, or a "DirectionInjection" node
+\item "calibration" (\link{character}): describe if the node is a "Gauged", or an "Ungauged" station,
+modelled with an hydrological model, or "NA" otherwise
\item "Upstream" (\link{logical}): is the node an upstream node?
\item "DirectInjection" (\link{logical}): is the node a Direct Injection node?
\item "Diversion" (\link{logical}): is the node a Diversion node?
diff --git a/tests/testthat/test-RunModel_Reservoir.R b/tests/testthat/test-RunModel_Reservoir.R
index ce1348bf99580a5cae19426d56236f7d36b0fa5f..f1c36289b3b79795939b7df7268d2d6ffdbd8ec9 100644
--- a/tests/testthat/test-RunModel_Reservoir.R
+++ b/tests/testthat/test-RunModel_Reservoir.R
@@ -11,27 +11,31 @@ test_that("Checks on GRiwrm object with Runmodel_Reservoir", {
skip_on_cran()
+nodes <- loadSevernNodes()
+
+# Reduce the network
+nodes <- nodes[nodes$id %in% c("54095", "54001"), ]
+nodes$down[nodes$id == "54001"] <- NA
+nodes$length[nodes$id == "54001"] <- NA
+# Insert a dam downstream the location the gauging station 54095
+# The dam is a direct injection node
+nodes$down[nodes$id == "54095"] <- "Dam"
+nodes$length[nodes$id == "54095"] <- 0
+nodes <- rbind(nodes,
+ data.frame(id = "Dam",
+ down = "54001",
+ length = 42,
+ area = NA,
+ model = "RunModel_Reservoir"))
+
+Qobs2 <- data.frame(
+ Dam = rep(0,11536)
+)
+
test_that("Calibration with Runmodel_Reservoir works!", {
- nodes <- loadSevernNodes()
-
- # Reduce the network
- nodes <- nodes[nodes$id %in% c("54095", "54001"), ]
- nodes$down[nodes$id == "54001"] <- NA
- nodes$length[nodes$id == "54001"] <- NA
- # Insert a dam downstream the location the gauging station 54095
- # The dam is a direct injection node
- nodes$down[nodes$id == "54095"] <- "Dam"
- nodes$length[nodes$id == "54095"] <- 0
- nodes <- rbind(nodes,
- data.frame(id = "Dam",
- down = "54001",
- length = 42,
- area = NA,
- model = "RunModel_Reservoir"))
+
g <- CreateGRiwrm(nodes)
- Qobs2 <- data.frame(
- Dam = rep(0,11536)
- )
+
e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
for(x in ls(e)) assign(x, get(x, e))
@@ -67,3 +71,30 @@ test_that("Calibration with Runmodel_Reservoir works!", {
expect_equal(OC[["Dam"]]$ParamFinalR, CalibOptions[["Dam"]]$FixedParam)
expect_gt(OC[["54001"]]$CritFinal, 0.96)
})
+
+test_that("Calibration with ungauged node and reservoir in the middle works", {
+
+ nodes$model[nodes$id == "54095"] <- "Ungauged"
+ g <- CreateGRiwrm(nodes)
+
+ expect_equal(g$donor[g$id == "54095"], "54001")
+
+ e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
+ for(x in ls(e)) assign(x, get(x, e))
+
+ InputsCrit <- CreateInputsCrit(InputsModel,
+ ErrorCrit_KGE2,
+ RunOptions = RunOptions,
+ Obs = Qobs[IndPeriod_Run, ])
+ CalibOptions <- CreateCalibOptions(InputsModel)
+ CalibOptions[["Dam"]]$FixedParam <- c(650E6, 1)
+ OC <- Calibration(
+ InputsModel = InputsModel,
+ RunOptions = RunOptions,
+ InputsCrit = InputsCrit,
+ CalibOptions = CalibOptions
+ )
+ # X1, X2, X3 are identical
+ expect_equal(OC$`54001`$ParamFinalR[2:4], OC$`54095`$ParamFinalR[1:3])
+ expect_equal(OC$Dam$ParamFinalR, CalibOptions[["Dam"]]$FixedParam)
+})
diff --git a/tests/testthat/test-RunModel_Ungauged.R b/tests/testthat/test-RunModel_Ungauged.R
index f91acd03e46104e3409c9a839641d106026e3162..54b1335a98c8d3bdac22b288b772493e809fdc56 100644
--- a/tests/testthat/test-RunModel_Ungauged.R
+++ b/tests/testthat/test-RunModel_Ungauged.R
@@ -1,29 +1,56 @@
skip_on_cran()
+
+# data set up
+nodes <- loadSevernNodes()
+
+nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ]
+nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA)
+nodes$model[nodes$id == "54029"] <- "Ungauged"
+
+g <- CreateGRiwrm(nodes)
+e <- setupRunModel(runRunModel = FALSE, griwrm = g)
+for(x in ls(e)) assign(x, get(x, e))
+
+np <- getAllNodesProperties(griwrm)
+
+IC <- CreateInputsCrit(
+ InputsModel,
+ FUN_CRIT = ErrorCrit_KGE2,
+ RunOptions = RunOptions,
+ Obs = Qobs[IndPeriod_Run, np$id[np$RunOff & np$calibration == "Gauged"]],
+ AprioriIds = c("54032" = "54001"),
+ transfo = "sqrt",
+ k = 0.15
+)
+
+CO <- CreateCalibOptions(InputsModel)
+OC <- Calibration(InputsModel, RunOptions, IC, CO)
+
test_that("RunModel_Ungauged works for intermediate basin with ungauged station", {
- # data set up
- nodes <- loadSevernNodes()
+ expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
+})
- nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ]
- nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA)
- nodes$model[nodes$id == "54029"] <- "Ungauged"
+test_that("RunModel_Ungauged works with a diversion as donor (#110)", {
+ nodes <- rbind(nodes,
+ data.frame(id = "54032", down = NA, length = NA, area = NA, model = "Diversion"))
g <- CreateGRiwrm(nodes)
-
- e <- setupRunModel(runRunModel = FALSE, griwrm = g)
+ Qobs2 <- matrix(0, ncol = 1, nrow = 11536)
+ colnames(Qobs2) <- "54032"
+ e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
for(x in ls(e)) assign(x, get(x, e))
-
np <- getAllNodesProperties(griwrm)
IC <- CreateInputsCrit(
InputsModel,
FUN_CRIT = ErrorCrit_KGE2,
RunOptions = RunOptions,
- Obs = Qobs[IndPeriod_Run, np$id[np$hydrology == "Gauged"]],
+ Obs = Qobs[IndPeriod_Run, np$id[np$RunOff & np$calibration == "Gauged"], drop = FALSE],
AprioriIds = c("54032" = "54001"),
transfo = "sqrt",
k = 0.15
)
CO <- CreateCalibOptions(InputsModel)
- OC <- suppressWarnings(Calibration(InputsModel, RunOptions, IC, CO))
- expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
+ OCdiv <- Calibration(InputsModel, RunOptions, IC, CO)
+ expect_equal(OCdiv, OC)
})
diff --git a/tests/testthat/test-createGRiwrm.R b/tests/testthat/test-createGRiwrm.R
index 8d34821d91cc64fd04649dd0e4e48e64fdff8773..9963748dc627a03eea34aafa503e82f40770258c 100644
--- a/tests/testthat/test-createGRiwrm.R
+++ b/tests/testthat/test-createGRiwrm.R
@@ -34,13 +34,10 @@ test_that("Duplicated nodes", {
regexp = "Duplicated nodes detected")
})
-test_that("NA or Ungauged nodes at downstream should throw an error", {
+test_that("Ungauged nodes without gauged node at downstream should throw an error", {
nodes$model[nodes$id == "54057"] <- "Ungauged"
expect_error(CreateGRiwrm(nodes),
- regexp = "downstream node")
- nodes$model[nodes$gauge_id == "54057"] <- NA
- expect_error(CreateGRiwrm(nodes),
- regexp = "downstream node")
+ regexp = "downstream the node")
})
test_that("Diversion node", {
@@ -55,10 +52,6 @@ test_that("Diversion node", {
n_orphan$id[n_orphan$model == "Diversion"] <- "54999"
expect_error(CreateGRiwrm(n_orphan),
regexp = "Diversion node must have the same `id` of")
- n_samedown <- nodes
- n_samedown$down[n_samedown$model == "Diversion"] <- "54032"
- expect_error(CreateGRiwrm(n_samedown),
- regexp = "downstream node of a Diversion node must be different")
})
test_that("Allow several downstream ends", {
diff --git a/tests/testthat/test-getNodeProperties.R b/tests/testthat/test-getNodeProperties.R
index b57262d2496e2161cbf9c9817edd072d08a0e0e0..8975feabe32372309f7a5e15aa8e71c529d58201 100644
--- a/tests/testthat/test-getNodeProperties.R
+++ b/tests/testthat/test-getNodeProperties.R
@@ -8,20 +8,20 @@ test_that("All nodes should have property: Diversion and DirectInjection == FALS
function(id) getNodeProperties(id, griwrm)[[p]])
expect_equal(all(prop_value), FALSE)
})
- prop_hydrology <- sapply(griwrm$id,
- function(id) getNodeProperties(id, griwrm)$hydrology)
- expect_equal(as.character(prop_hydrology), rep("Gauged", nrow(griwrm)))
+ prop_calibration <- sapply(griwrm$id,
+ function(id) getNodeProperties(id, griwrm)$calibration)
+ expect_equal(as.character(prop_calibration), rep("Gauged", nrow(griwrm)))
})
-test_that("Ungauged station has 'hydrology:Ungauged' property", {
+test_that("Ungauged station has 'calibration:Ungauged' property", {
nodes$model[nodes$id == "54029"] <- "Ungauged"
- expect_equal(getNodeProperties("54029", CreateGRiwrm(nodes))$hydrology, "Ungauged")
+ expect_equal(getNodeProperties("54029", CreateGRiwrm(nodes))$calibration, "Ungauged")
})
-test_that("Direct injection node has 'hydrology:NA' property", {
+test_that("Direct injection node has 'calibration:NA' property", {
nodes$model[nodes$id == "54002"] <- NA
np <- getNodeProperties("54002", CreateGRiwrm(nodes))
- expect_equal(np$hydrology, "NA")
+ expect_equal(np$calibration, "NA")
expect_equal(np$DirectInjection, TRUE)
})