Skip to content
GitLab
Select Git revision
  • cobra
  • master default
Find file BlameHistoryPermalink
getNodeProperties.R 3.75 KiB
1 
#' Properties of GRiwrm nodes
2 
#'
3 
#' `getNodeProperties` returns properties of a single node, and
4 
#'
5 
#' @param id [character] Id of the node in the GRiwrm object
6 
#' @param griwrm \[GRiwrm object\] describing the network of the semi-distributed model (See [CreateGRiwrm])
7 
#'
8 
#' @return `getNodeProperties` returns a [list] with the following items:
9 
#' - "position" ([character]): Position of the node in the network ("Upstream" or "Intermediate")
10 
#' - "DirectInjection" ([logical]): is the node a Direct Injection node?
11 
#' - "Diversion" ([logical]): is the node a Diversion node?
12 
#' - "Reservoir" ([logical]): is the node a Reservoir?
13 
#' - "airGR" ([logical]): is the node contains an airGR model?
14 
#' - "calibration" ([character]): describe if the node is a "Gauged", or an "Ungauged" station,
15 
#'   (see details), or "NA" otherwise
16 
#' - "Upstream" ([logical]): is the node an upstream node?
17 
#' - "RunOff" ([logical]): is the node contains an hydrological model?
18 
#'
19 
#' `getAllNodesProperties` returns a [data.frame] constituted from the list returned
20 
#' by `getNodeProperties` for all nodes.
21 
#'
22 
#' @details
23 
#' A "Gauged" node is either a node containing a model that is already
24 
#' calibrated (parameters are already fixed) or a node containing a model where
25 
#' observations are available for calibration.
26 
#'
27 
#' A "Ungauged" node is a node containing a model which derives its parameters from
28 
#' another "donor" node.
29 
#'
30 
#' @export
31 
#' @rdname getNodeProperties
32 
#' @seealso [CreateGRiwrm()]
33 
#'
34 
#' @example man-examples/getNodeProperties.R
35 
getNodeProperties <- function(id, griwrm) {
36 
  stopifnot(inherits(griwrm, "GRiwrm"),
37 
            "donor" %in% names(griwrm))
38 
  g2 <- griwrm[getDiversionRows(griwrm, TRUE), , drop = FALSE]
39 
  upstreamIds <- griwrm$id[!griwrm$id %in% griwrm$down]
40 
  model <- g2$model[g2$id == id]
41 
  if (is.na(model)) {
42 
    donor_model <- "DirectInjection"
43 
  } else {
44 
    donor_model <- g2$model[g2$id == g2$donor[g2$id == id]]
45 
  }
46 
  p <- list(
47 
    position = ifelse(id %in% upstreamIds, "Upstream", "Intermediate"),
48 
    DirectInjection = is.na(model),
49 
    Diversion = "Diversion" %in% griwrm$model[griwrm$id == id],
50 
    Reservoir = !is.na(model) && model == "RunModel_Reservoir",
51 
    airGR = grepl("RunModel_", donor_model)
52 
  )
53 
  p$gauged <- isNodeGauged(id, griwrm)
54 
  if (p$DirectInjection) {
55 
    p$calibration <- "NA"
56 
  } else {
57 
    if (p$gauged) {
58 
      if (p$Reservoir) {
59 
        p$calibration <- "Reservoir"
60 
      } else {
61 
        p$calibration <- "Gauged"
62 
      }
63 
    } else {
64 
      if (is.na(griwrm$donor[id]) || isNodeDownstream(griwrm, id, griwrm$donor[id])) {
65 
        p$calibration <- "Ungauged"
66 
      } else {
67 
        p$calibration <- "Receiver"
68 
      }
69 
    }
70 
  }
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108
p$Upstream <- p$position == "Upstream" p$RunOff <- !p$DirectInjection && !p$Reservoir && donor_model != "RunModel_Lag" return(p) } #' @export #' @rdname getNodeProperties #' getAllNodesProperties <- function(griwrm) { stopifnot(inherits(griwrm, "GRiwrm")) uids <- griwrm$id[getDiversionRows(griwrm, TRUE)] nodeProperties <- lapply(uids, getNodeProperties, griwrm = griwrm) df <- do.call(rbind, lapply(nodeProperties, dplyr::bind_cols)) df <- cbind(id = uids, df) rownames(df) <- uids return(df) } #' Does this node contains a gauged model? #' #' @inheritParams getNodeProperties #' @param skip_reservoirs if TRUE reservoirs are accounted for ungauged #' #' @return `TRUE` if the node contains a gauged model, `FALSE` if not. #' @noRd #' isNodeGauged <- function(id, griwrm, skip_reservoirs = FALSE) { g2 <- griwrm[getDiversionRows(griwrm, inverse = TRUE), , drop = FALSE] model <- g2$model[g2$id == id] ungaugedModels <- c("Ungauged") if (skip_reservoirs) ungaugedModels <- c(ungaugedModels, "RunModel_Reservoir") return(!is.na(model) && !model %in% ungaugedModels) }