diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index 8c374544ce685b18385f353fabe8256a8309270c..931a4c88a9adc10ab0fc60a320365d7110257bcd 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -77,7 +77,6 @@ CreateInputsModel.GRiwrm <- function(x, DatesR, if (err) stop(sprintf("'Qobs' column names must at least contain %s", paste(directFlowIds, collapse = ", "))) } - InputsModel <- CreateEmptyGRiwrmInputsModel(x) # Qobs completion @@ -146,7 +145,7 @@ CreateEmptyGRiwrmInputsModel <- function(griwrm) { #' @noRd CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs) { node <- griwrm[griwrm$id == id,] - FUN_MOD <- griwrm$model[griwrm$id == id] + FUN_MOD <- getDownstreamModel(id, griwrm) # Set hydraulic parameters UpstreamNodes <- griwrm$id[griwrm$down == id & !is.na(griwrm$down)] @@ -193,6 +192,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs) { # Add the model function InputsModel$FUN_MOD <- FUN_MOD + InputsModel$IsUngauged <- griwrm$model[griwrm$id == id] == "Ungauged" + InputsModel$hasUngaugedNodes <- hasUngaugedNodes(id, griwrm) return(InputsModel) } @@ -250,3 +251,46 @@ getInputBV <- function(x, id, unset = NULL) { } return(x[, id]) } + + +#' Get the model downstream if current node as no model defined +#' +#' @param id [character] Id of the current node +#' @param griwrm See [CreateGRiwrm]) +#' +#' @return [character] Id of the first node with a model +#' +#' @noRd +getDownstreamModel <- function(id, griwrm) { + if(!is.na(griwrm$model[griwrm$id == id]) & griwrm$model[griwrm$id == id] != "Ungauged") { + return(griwrm$model[griwrm$id == id]) + } else if(!is.na(griwrm$down[griwrm$id == id])){ + return(getDownstreamModel(griwrm$down[griwrm$id == id], griwrm)) + } else { + stop("The model of the downstream node of a network cannot be `NA` or \"Ungauged\"") + } +} + + +#' Check if current node contains ungauged nodes that shares its parameters +#' +#' @param id id [character] Id of the current node +#' @param griwrm See [CreateGRiwrm]) +#' +#' @return A [logical], `TRUE` if the node `id` contains ungauged nodes. +#' +#' @noRd +hasUngaugedNodes <- function(id, griwrm) { + upIds <- griwrm$id[griwrm$down == id] + # No upstream nodes + if(length(upIds) == 0) return(FALSE) + # At least one upstream node is ungauged + if(any(griwrm$model[griwrm$id %in% upIds] == "Ungauged")) 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]))) { + NaIds <- griwrm$id[is.na(griwrm$model[griwrm$id %in% upIds])] + out <- sapply(NaIds, hasUngauged, griwrm = griwrm) + return(any(out)) + } + return(FALSE) +} diff --git a/man/plot.GRiwrm.Rd b/man/plot.GRiwrm.Rd index d34e84696761155869750f00febc569b4f8ba8fe..705507759a2ec303e10163c5ae75d933ccdf26bc 100644 --- a/man/plot.GRiwrm.Rd +++ b/man/plot.GRiwrm.Rd @@ -10,6 +10,8 @@ orientation = "LR", width = "100\%", height = "100\%", + box_colors = c(UpstreamUngauged = "#eef", UpstreamGauged = "#aaf", IntermUngauged = + "#efe", IntermGauged = "#afa", DirectInjection = "#faa"), ... ) } @@ -24,6 +26,8 @@ \item{height}{\link{numeric} height of the resulting graphic in pixels (See \link[DiagrammeR:mermaid]{DiagrammeR::mermaid})} +\item{box_colors}{\link{list} containing the color used for the different types of nodes} + \item{...}{Other arguments and parameters you would like to send to JavaScript (See \link[DiagrammeR:mermaid]{DiagrammeR::mermaid})} } \value{ diff --git a/vignettes/V05_Modelling_ungauged_nodes.Rmd b/vignettes/V05_Modelling_ungauged_nodes.Rmd index c0c81fbff225ac8abd440484e6f2c7f5e4bd67b7..7fd5049292360f5bf49dfcbaee6f53fd076f5ff0 100644 --- a/vignettes/V05_Modelling_ungauged_nodes.Rmd +++ b/vignettes/V05_Modelling_ungauged_nodes.Rmd @@ -52,7 +52,7 @@ id95[54095] id01[54001] id29[54029] -subgraph 54032 +subgraph Shared parameters from node 54032 id01 -->| 45 km| 54032 id95 -->| 42 km| id01 id29 -->| 32 km| 54032 @@ -118,7 +118,7 @@ Qobs <- cbind(sapply(BasinsObs, function(x) {x$discharge_spec})) Then, the `GRiwrmInputsModel` object can be generated taking into account the new `GRiwrm` object: ```{r} -#IM_OL <- CreateInputsModel(griwrmV05, DatesR, Precip, PotEvap, Qobs) +IM_U <- CreateInputsModel(griwrmV05, DatesR, Precip, PotEvap, Qobs) ``` # References