feat: handle ungauged nodes in plot.GRiwrm

- modify plot.GRiwrm
- create dedicated vignette
- add Lobligeois references in the  bibliography
- clean bibtex file
- Add function for automatic cleaning of the bibtex file

Refs #42

R/plot.GRiwrm.R

@@ -5,6 +5,7 @@
 #' @param orientation [character] orientation of the graph. Possible values are "LR" (left-right), "RL" (right-left), "TB" (top-bottom), or "BT" (bottom-top). "LR" by default
 #' @param width [numeric] width of the resulting graphic in pixels (See [DiagrammeR::mermaid])
 #' @param height [numeric] height of the resulting graphic in pixels (See [DiagrammeR::mermaid])
+#' @param box_colors [list] containing the color used for the different types of nodes
 #' @param ... Other arguments and parameters you would like to send to JavaScript (See [DiagrammeR::mermaid])
 #'
 #' @details This function only works inside RStudio because the HTMLwidget produced by DiagrammeR
@@ -22,22 +23,51 @@
 #' DiagrammeR::mermaid(plot.GRiwrm(griwrm, display = FALSE), width = "100%", height = "100%")
 #' }
 #'
-plot.GRiwrm <- function(x, display = TRUE, orientation = "LR", width = "100%", height = "100%", ...) {
+plot.GRiwrm <- function(x,
+                        display = TRUE,
+                        orientation = "LR",
+                        width = "100%",
+                        height = "100%",
+                        box_colors = c(UpstreamUngauged = "#eef",
+                                       UpstreamGauged = "#aaf",
+                                       IntermUngauged = "#efe",
+                                       IntermGauged = "#afa",
+                                       DirectInjection = "#faa"),
+                        ...) {
+
+  stopifnot(inherits(x, "GRiwrm"),
+            is.logical(display),
+            length(display) == 1,
+            is.character(orientation),
+            length(orientation) == 1,
+            is.character(width),
+            length(width) == 1,
+            is.character(height),
+            length(height) == 1,
+            is.character(box_colors),
+            length(setdiff(names(box_colors), c("UpstreamUngauged", "UpstreamGauged",
+                                                "IntermUngauged",   "IntermGauged",
+                                                "DirectInjection"))) == 0)
   g2 <- x[!is.na(x$down),]
   nodes <- paste(
-    g2$id,
+    sprintf("id_%1$s[%1$s]", g2$id),
     "-->|",
     round(g2$length, digits = 0),
     "km|",
-    g2$down
+    sprintf("id_%1$s[%1$s]", g2$down)
   )
-  styleSD <- paste("style", unique(g2$down), "fill:#cfc")
-  if (length(g2$id[is.na(g2$model)]) > 0) {
-    styleDF <- paste("style", unique(g2$id[is.na(g2$model)]), "fill:#fcc")
-  } else {
-    styleDF <- ""
-  }
-  diagram <- paste(c(paste("graph", orientation), nodes, styleSD, styleDF), collapse = "\n")
+  node_class <- list(
+    UpstreamUngauged = x$id[!x$id %in% x$down & x$model == "Ungauged"],
+    UpstreamGauged = x$id[!x$id %in% x$down & x$model != "Ungauged" & !is.na(x$model)],
+    IntermUngauged = x$id[x$id %in% x$down & x$model == "Ungauged"],
+    IntermGauged = x$id[x$id %in% x$down & x$model != "Ungauged" & !is.na(x$model)],
+    DirectInjection = x$id[is.na(x$model)]
+  )
+  node_class <- lapply(node_class, function(x) if(length(x) > 0) paste0("id_", x))
+  node_class[sapply(node_class, is.null)] <- NULL
+  node_class <- paste("class", sapply(node_class, paste, collapse = ","), names(node_class))
+  css <- paste("classDef", names(box_colors), paste0("fill:", box_colors))
+  diagram <- paste(c(paste("graph", orientation), nodes, node_class, css), collapse = "\n\n")
   if (display) {
     DiagrammeR::mermaid(diagram = diagram, width, height, ...)
   } else {

dev/clean_bibtex.R

+#' Remove unecessary fields in .bib file
+#'
+#' @param path the path of the .bib file
+#' @param pattern pattern for search files in `path`
+#' @param rm.fields ([character] [vector]) list of fields to remove
+#'
+#' @return Function used for side effect.
+#' @export
+#'
+clean_bibtex <- function(path = "./vignettes",
+                         pattern = "*.bib",
+                         rm.fields = c("abstract", "langid", "file", "keywords", "copyright", "annotation")) {
+  files <- list.files(path = path, pattern = pattern)
+  message("Found files to clean: ", paste(files, collapse = ", "))
+  lapply(files, function(f) {
+    s <- readLines(file.path(path, f))
+    n <- length(s)
+    for (rm.field in rm.fields) {
+      s <- s[!grepl(paste0("^\\s*", rm.field), s)]
+    }
+    writeLines(s, file.path(path, f))
+    message(n - length(s), " lines removed in ", f)
+  })
+  invisible()
+}

tests/testthat/test-plot.R

-test_that("plot.GRiwrm should have all styles correctly filled (#73)", {
-  data(Severn)
-  nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")]
-  nodes$distance_downstream <- nodes$distance_downstream #je ne comprends pas cette ligne, elle semble inutile
-  nodes$model <- "RunModel_GR4J"
-  griwrm <- CreateGRiwrm(nodes, list(id = "gauge_id", down = "downstream_id", length = "distance_downstream"))
-  code_mermaid <-plot(griwrm, display = FALSE)
-  expect_length(grep("style  fill", code_mermaid), 0)
-})

vignettes/V05_Modelling_ungauged_nodes.Rmd

+---
+title: "Severn_05: Modelling ungauged stations"
+output: rmarkdown::html_vignette
+vignette: >
+  %\VignetteIndexEntry{Severn_05: Modelling ungauged stations}
+  %\VignetteEngine{knitr::rmarkdown}
+  %\VignetteEncoding{UTF-8}
+bibliography: airGRiwrm.bib
+---
+
+```{r, include = FALSE}
+knitr::opts_chunk$set(
+  collapse = TRUE,
+  comment = "#>",
+  fig.width = 6,
+  fig.asp = 0.68,
+  out.width = "70%",
+  fig.align = "center"
+)
+```
+
+```{r setup}
+library(airGRiwrm)
+```
+
+## Why modelling ungauged station in the semi-distributed model?
+
+This vignette introduces the implementation in airGRiwrm of the model developped by @lobligeoisMieuxConnaitreDistribution2014
+
+2 interests:
+
+- increase spatial resolution of the rain fall to improve streamflow simulation [@lobligeoisWhenDoesHigher2014].
+- simulate streamflows in location of interest for management purpose
+
+## Presentation of the study case
+
+Using the study case of the vignette #1 and #2, we considere this time that nodes `54095`, `54001` and 
+`54029` are ungauged. We simulate the streamflow at these locations by sharing 
+hydrological parameters of the gauged node `54032`.
+
+```{r, echo = FALSE}
+mmd <- function(x, ...) {
+  # For avoiding crash of R CMD build in console mode
+  if(Sys.getenv("RSTUDIO") == "1") {
+    DiagrammeR::mermaid(x, ...)
+  }
+}
+
+mmd("
+graph LR
+id95[54095]
+id01[54001]
+id29[54029]
+
+subgraph 54032
+id01 -->| 45 km| 54032
+id95 -->| 42 km| id01
+id29 -->| 32 km| 54032
+end
+
+54032 -->| 15 km| 54057
+54002 -->| 43 km| 54057
+
+classDef UpUng fill:#eef
+classDef UpGau fill:#aaf
+classDef IntUng fill:#efe
+classDef IntGau fill:#afa
+classDef DirInj fill:#faa
+
+class id95,id29 UpUng
+class 54057,54032 IntGau
+class id01 IntUng
+class 54002 UpGau
+")
+```
+
+Hydrological parameters at the ungauged nodes will be the same as the one at the gauged node `54032` except for the unit hydrogram parameter which depend on the area of the sub-basin. @lobligeoisMieuxConnaitreDistribution2014 provides the following conversion formula for this parameter:
+
+$$
+x_{4i} = \left( \dfrac{S_i}{S_{BV}} \right) ^ {0.3} X_4
+$$
+With $X_4$ the unit hydrogram parameter for the entire basin at `54032` which as an area of $S_{BV}$; $S_i$ the area and $x_{4i}$ the parameter for the sub-basin $i$.
+
+## Using ungauged stations in the airGRiwrm model
+
+Ungauged stations are specified by using the model "Ungauged" in the `model` column provided in the `CreateGRiwrm` function:
+
+```{r}
+data(Severn)
+nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")]
+nodes$model <- "RunModel_GR4J"
+nodes$model[nodes$gauge_id %in% c("54095", "54029", "54001")] <- "Ungauged"
+griwrmV05 <- CreateGRiwrm(nodes, list(id = "gauge_id", down = "downstream_id", length = "distance_downstream"))
+griwrmV05
+```
+
+On the following network scheme, the ungauged nodes are cleared than gauged ones with the same color (blue for upstream nodes and green for intermediate and downstream nodes)
+
+```{r}
+plot(griwrmV05)
+```
+
+
+## Generation of the GRiwrmInputsModel object
+
+The formatting of the input data is described in the vignette "V01_Structure_SD_model". The following code chunk resumes this formatting procedure:
+
+```{r}
+BasinsObs <- Severn$BasinsObs
+DatesR <- BasinsObs[[1]]$DatesR
+PrecipTot <- cbind(sapply(BasinsObs, function(x) {x$precipitation}))
+PotEvapTot <- cbind(sapply(BasinsObs, function(x) {x$peti}))
+Precip <- ConvertMeteoSD(griwrmV05, PrecipTot)
+PotEvap <- ConvertMeteoSD(griwrmV05, PotEvapTot)
+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)
+```
+
+# References