Skip to content
GitLab
Select Git revision
Find file BlameHistoryPermalink
utils.Calibration.R 11.22 KiB
1 
#' Create InputsCrit for De Lavenne regularization
2 
#'
3 
#' Internal function that run [airGR::CreateInputsCrit_Lavenne] on-the-fly with a priori upstream
4 
#' sub-catchment parameters grabbed during network calibration process.
5 
#'
6 
#' @param id [character] the id of the current sub-catchment
7 
#' @param OutputsModel \[GRiwrmOutputsModel\] object with simulation results of upstream sub-catchments run with calibrated parameters
8 
#' @param InputsCrit \[InputsCritLavenneFunction\] object internally created by [CreateInputsCrit.GRiwrmInputsModel]
9 
#'
10 
#' @return \[InputsCrit\] object with De Lavenne regularization
11 
#' @import airGR
12 
#' @noRd
13 
#'
14 
getInputsCrit_Lavenne <- function(id, OutputsModel, InputsCrit) {
15 
  if (!inherits(InputsCrit[[id]], "InputsCritLavenneFunction")) {
16 
    stop("'InputsCrit[[id]]' must be of class InputsCritLavenneFunction")
17 
  }
18 
  AprioriId <- attr(InputsCrit[[id]], "AprioriId")
19 
  AprCelerity <- attr(InputsCrit[[id]], "AprCelerity")
20 
  Lavenne_FUN <- attr(InputsCrit[[id]], "Lavenne_FUN")
21 
  AprParamR <- OutputsModel[[AprioriId]]$RunOptions$Param
22 
  if (!inherits(OutputsModel[[AprioriId]], "SD")) {
23 
    # Add Celerity parameter if apriori is an upstream node
24 
    AprParamR <- c(AprCelerity, AprParamR)
25 
  }
26 
  featMod <- attr(InputsCrit[[id]], "model")
27 
  if (featMod$hasX4) {
28 
    AprParamR[featMod$iX4] <- AprParamR[featMod$iX4] * featMod$X4Ratio
29 
  }
30 
  AprParamR <- AprParamR[featMod$indexParamUngauged]
31 
  message("Parameter regularization: get a priori parameters from node ", AprioriId, ": ", paste(round(AprParamR, 3), collapse = ", "))
32 
  AprCrit <- ErrorCrit(InputsCrit[[AprioriId]], OutputsModel[[AprioriId]])$CritValue
33 
  return(Lavenne_FUN(AprParamR, AprCrit))
34 
}
35
36
37 
#' Reduce a GRiwrm list object (InputsModel, RunOptions...) for a reduced network
38 
#'
39 
#' @param griwrm See [CreateGRiwrm])
40 
#' @param obj Either a *GRiwrmInputsModel*, *GRiwrmOptions*... object
41 
#'
42 
#' @return The object containing only nodes of the reduced model
43 
#' @noRd
44 
reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
45 
  objAttributes <- attributes(obj)
46 
  obj <- lapply(obj, function(o) {
47 
    if (o$id %in% griwrm$id && any(!is.na(griwrm$model[griwrm$id == o$id]))) {
48 
      o
49 
    } else {
50 
      NULL
51 
    }
52 
  })
53 
  obj[sapply(obj, is.null)] <- NULL
54 
  objAttributes$names <- names(obj)
55 
  attributes(obj) <- objAttributes
56 
  return(obj)
57 
}
58
59 
#' Set a reduced GRiwrm network for calibration of a sub-network with ungauged
60 
#' hydrological nodes
61 
#'
62 
#' @inheritParams Calibration
63 
#' @param GaugedId [character] Id of the gauged node
64 
#' @param OutputsModel *GRiwrmOutputsModel* of the complete network
65 
#'
66 
#' @return A [list] containing the following items:
67 
#' - `InputsModel`: a *GRiwrmInputsModel* of the reduced network
68 
#' - `RunOptions`: a *GRiwrmRunOptions* of the reduced network
69 
#' @noRd
70 
#' @importFrom dplyr "%>%"
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
#' @importFrom rlang .data #' updateParameters4Ungauged <- function(GaugedId, InputsModel, RunOptions, CalibOptions, OutputsModel, useUpstreamQsim) { g <- getUngaugedCluster(attr(InputsModel, "GRiwrm"), GaugedId) ### Modify InputsModel for the reduced network ### # Remove nodes outside of reduced network InputsModel <- reduceGRiwrmObj4Ungauged(g, InputsModel) # Copy fixed parameters for Reservoirs or other models for (id in names(InputsModel)) { if (id != GaugedId && InputsModel[[id]]$gaugedId == id) { if (any(is.na(CalibOptions[[id]]$FixedParam))) { stop("Node '", id, "' located inside the ungauged node cluster '", GaugedId, "' must have its parameters fixed.\n", "Fix its parameters by assigning values to :", " `CalibOptions[['", id, "']]$FixedParam`") } InputsModel[[id]]$FixedParam <- CalibOptions[[id]]$FixedParam } } # Update griwrm attr(InputsModel, "GRiwrm") <- g # Update Qupstream already modeled in the reduced network upstream nodes upIds <- attr(g, "upIds") idIM <- unique(g$down[g$id %in% upIds]) for (id in idIM) { if (useUpstreamQsim && any(InputsModel[[id]]$UpstreamIsModeled)) { # Temporarily switch off upstream nodes belonging to the donor basin UpIsModeledBackUp <- InputsModel[[id]]$UpstreamIsModeled ImUpIds <- InputsModel[[id]]$UpstreamNodes InputsModel[[id]]$UpstreamIsModeled[!ImUpIds %in% upIds] <- FALSE # Update InputsModel$Qupstream with simulated upstream flows InputsModel[[id]] <- UpdateQsimUpstream(InputsModel[[id]], RunOptions[[id]], OutputsModel) # Restore initial UpstreamIsModeled and switch off already modeled nodes InputsModel[[id]]$UpstreamIsModeled <- UpIsModeledBackUp InputsModel[[id]]$UpstreamIsModeled[ImUpIds %in% upIds] <- FALSE } } # Add class RunModel_Ungauged and InputsModel for preprocessind # and processing airGR::Calibration class(InputsModel) <- c("Ungauged", "InputsModel", class(InputsModel)) ### Modify RunOptions for the reduced network ### RunOptions <- reduceGRiwrmObj4Ungauged(g, RunOptions) return(list(InputsModel = InputsModel, RunOptions = RunOptions)) } #' Compute the area of downstream sub-basins #' #' @param IM *GRiwrmInputsModel* object (See [CreateInputsModel.GRiwrm]) #' #' @return [numeric] named [vector] of the area of the downstream sub-basins #' @noRd calcSubBasinAreas <- function(IM) { unlist( sapply(IM, function(x) { if (is.list(x)) as.numeric(x$BasinAreas[length(x$BasinAreas)])}) ) }