feat: add extractParam

Also moved calibration tools into utils.Calibration.R

Refs #86

NAMESPACE

@@ -44,6 +44,7 @@ export(CreateSupervisor)
 export(RunModel)
 export(RunModel_Reservoir)
 export(as.Qm3s)
+export(extractParam)
 export(getAllNodesProperties)
 export(getNoSD_Ids)
 export(getNodeProperties)

R/Calibration.GRiwrmInputsModel.R

@@ -133,261 +133,3 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
   return(OutputsCalib)
 
 }
-
-#' Create InputsCrit for De Lavenne regularization
-#'
-#' Internal function that run [airGR::CreateInputsCrit_Lavenne] on-the-fly with a priori upstream
-#' sub-catchment parameters grabbed during network calibration process.
-#'
-#' @param id [character] the id of the current sub-catchment
-#' @param OutputsModel \[GRiwrmOutputsModel\] object with simulation results of upstream sub-catchments run with calibrated parameters
-#' @param InputsCrit \[InputsCritLavenneFunction\] object internally created by [CreateInputsCrit.GRiwrmInputsModel]
-#'
-#' @return \[InputsCrit\] object with De Lavenne regularization
-#' @import airGR
-#' @noRd
-#'
-getInputsCrit_Lavenne <- function(id, OutputsModel, InputsCrit) {
-  if (!inherits(InputsCrit[[id]], "InputsCritLavenneFunction")) {
-    stop("'InputsCrit[[id]]' must be of class InputsCritLavenneFunction")
-  }
-  AprioriId <- attr(InputsCrit[[id]], "AprioriId")
-  AprCelerity <- attr(InputsCrit[[id]], "AprCelerity")
-  Lavenne_FUN <- attr(InputsCrit[[id]], "Lavenne_FUN")
-  AprParamR <- OutputsModel[[AprioriId]]$RunOptions$Param
-  if (!inherits(OutputsModel[[AprioriId]], "SD")) {
-    # Add Celerity parameter if apriori is an upstream node
-    AprParamR <- c(AprCelerity, AprParamR)
-  }
-  featMod <- attr(InputsCrit[[id]], "model")
-  if (featMod$hasX4) {
-    AprParamR[featMod$iX4] <- AprParamR[featMod$iX4] * featMod$X4Ratio
-  }
-  AprParamR <- AprParamR[featMod$indexParamUngauged]
-  message("A priori parameters from node ", AprioriId, ": ", paste(round(AprParamR, 3), collapse = ", "))
-  AprCrit <- ErrorCrit(InputsCrit[[AprioriId]], OutputsModel[[AprioriId]])$CritValue
-  return(Lavenne_FUN(AprParamR, AprCrit))
-}
-
-
-#' Reduce a GRiwrm list object (InputsModel, RunOptions...) for a reduced network
-#'
-#' @param griwrm See [CreateGRiwrm])
-#' @param obj Either a *GRiwrmInputsModel*, *GRiwrmOptions*... object
-#'
-#' @return The object containing only nodes of the reduced model
-#' @noRd
-reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
-  objAttributes <- attributes(obj)
-  obj <- lapply(obj, function(o) {
-    if (o$id %in% griwrm$id && any(!is.na(griwrm$model[griwrm$id == o$id]))) {
-      o
-    } else {
-      NULL
-    }
-  })
-  obj[sapply(obj, is.null)] <- NULL
-  objAttributes$names <- names(obj)
-  attributes(obj) <- objAttributes
-  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
-#' @importFrom dplyr "%>%"
-#' @importFrom rlang .data
-#'
-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 donor gauged node
-  griwrm <- attr(InputsModel, "GRiwrm")
-  donorIds <- griwrm$id[!is.na(griwrm$donor) & griwrm$donor == GaugedId]
-  gDonor <- griwrm %>% dplyr::filter(.data$id %in% donorIds)
-  # Add upstream nodes for routing upstream flows
-  upNodes <- griwrm %>%
-    dplyr::filter(.data$down %in% gDonor$id,
-                  !.data$id %in% gDonor$id) %>%
-    dplyr::mutate(model = ifelse(!is.na(.data$model), NA, .data$model))
-  upIds <- upNodes$id
-  g <- rbind(upNodes, gDonor)
-  # Set downstream nodes
-  g$down[!g$down %in% g$id] <- NA
-
-  ### 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 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)) {
-      # 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 InputsModel for airGR::Calibration checks
-  class(InputsModel) <- c("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)])})
-  )
-}
-
-
-#' RunModel for a sub-network of ungauged nodes
-#'
-#' The function simulates a network with one set of parameters
-#' shared with ungauged nodes inside the basin.
-#'
-#' @details
-#' The network should contains only one gauged station at downstream and other
-#' nodes can be direct injection or ungauged nodes.
-#'
-#' This function works as functions similar to [airGR::RunModel_GR4J] except that
-#' `InputsModel` is a *GRiwrmInputsModel* containing the network of ungauged nodes
-#' and direct injection in the basin.
-#'
-#' `Param` is adjusted for each sub-basin using the method developed by
-#' Lobligeois (2014) for GR models.
-#'
-#' @references Lobligeois, Florent. Mieux connaître la distribution spatiale des
-#' pluies améliore-t-il la modélisation des crues ? Diagnostic sur 181 bassins
-#' versants français. Phdthesis, AgroParisTech, 2014.
-#' <https://pastel.hal.science/tel-01134990/document>
-#'
-#' @inheritParams airGR::RunModel
-#' @param ouput.all [logical] if `TRUE` returns the output of [RunModel.GRiwrm],
-#' returns the `OutputsModel` of the downstream node otherwise
-#'
-#' @inherit RunModel.GRiwrmInputsModel return return
-#' @noRd
-RunModel_Ungauged <- function(InputsModel, RunOptions, Param, output.all = FALSE) {
-  InputsModel$FUN_MOD <- NULL
-  donor <- RunOptions$id
-  # Compute Param for each sub-basin
-  P <- lapply(InputsModel, function(IM) {
-    if (IM$id == donor) return(Param)
-    if (IM$isReservoir) {
-      return(IM$FixedParam)
-    }
-    return(transferGRparams(InputsModel, Param, donor, IM$id))
-  })
-  OM <- suppressMessages(
-    RunModel.GRiwrmInputsModel(InputsModel, attr(RunOptions, "GRiwrmRunOptions"), P)
-  )
-  if (output.all) {
-    return(OM)
-  } else {
-    return(OM[[length(OM)]])
-  }
-}
-
-#' Transfer GR parameters from one donor sub-basin to a receiver sub-basin
-#'
-#' This function is used by `Calibration.GRiwrmInputsModel` for transferring parameters
-#' to ungauged nodes and
-#'
-#' @details
-#' `donor` and `receiver` nodes should have the same GR model with the same snow
-#' module configuration.
-#'
-#' The transfer takes care of:
-#' - the presence/absence of hydraulic routing parameters between the donor and the receiver
-#' - the transformationof the X4 parameters of GR models
-#'
-#' @param InputsModel A *GRiwrmInputsModel* object (See [CreateInputsModel.GRiwrm])
-#' @param Param [numeric] vector of GR model parameters
-#' @param donor [character] id of the node which gives its parameters
-#' @param receiver [character] id of the node which receives the parameters from the donor
-#' @param default_param [numeric] vector of GR model parameters if parameters are missing from the donor
-#'
-#' @return A [numeric] [vector] with transferred parameters
-#' @export
-#'
-transferGRparams <- function(InputsModel, Param, donor, receiver, default_param = NULL) {
-  missing_params <- setdiff(InputsModel[[receiver]]$model$indexParamUngauged,
-                            InputsModel[[donor]]$model$indexParamUngauged)
-  if (length(missing_params) > 0) {
-    if (is.null(default_param)) {
-      stop("Missing parameters in transfer between nodes '",
-           donor, "' and '", receiver, "'\n",
-           "Fix the missing parameters with the argument `FixedParam` of `CreateCalibOptions`")
-    }
-    max_params <- max(
-      max(InputsModel[[receiver]]$model$indexParamUngauged),
-      max(InputsModel[[donor]]$model$indexParamUngauged)
-    )
-    if (length(default_param) < max_params) {
-      stop("Error in parameter transfer between nodes '", donor, "' and '",
-           receiver, "'\n`default_params` should have a minimum length of ", max_params)
-    }
-    Param2 <- rep(as.numeric(NA), length(InputsModel[[receiver]]$model$indexParamUngauged))
-    Param2[InputsModel[[donor]]$model$indexParamUngauged] <- Param
-    Param2[missing_params] <- default_param[missing_params]
-    Param <- Param2
-  }
-
-  p <- Param
-  if (length(Param) > length(InputsModel[[receiver]]$model$indexParamUngauged)) {
-    # Transfer from intermediate node to upstream node
-    p <- p[InputsModel[[receiver]]$model$indexParamUngauged]
-  }
-
-  if (InputsModel[[receiver]]$model$hasX4) {
-    donor_area <- InputsModel[[donor]]$BasinAreas[length(InputsModel[[donor]]$BasinAreas)]
-    receiver_area <- InputsModel[[receiver]]$BasinAreas[length(InputsModel[[receiver]]$BasinAreas)]
-    p[InputsModel[[receiver]]$model$iX4] <- max(
-      Param[InputsModel[[donor]]$model$iX4] *
-        (receiver_area / donor_area) ^ 0.3,
-      0.5
-    )
-  }
-  return(p)
-}

R/Calibration.R

 #' Calibration of the parameters of one catchment or a network of sub-catchments
 #'
-#' Calibration algorithm that optimizes the error criterion selected as objective function using the provided functions.
+#' Calibration algorithm that optimizes the error criterion selected as objective
+#' function using the provided functions.
 #'
-#' This function can be used either for a catchment (with an \emph{InputsModel} object) or for a network (with a \emph{GRiwrmInputsModel} object)
+#' This function can be used either for a catchment (with an \emph{InputsModel}
+#' object) or for a network (with a \emph{GRiwrmInputsModel} object)
 #'
 #' @param InputsModel \[object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}\] see [CreateInputsModel]
 #' @param RunOptions \[object of class \emph{RunOptions} or \emph{GRiwrmRunOptions}\] see [CreateRunOptions]
@@ -11,14 +13,21 @@
 #' @param ... further arguments passed to [airGR::Calibration], see details
 #'
 #' @details Argument classes should be consistent to the usage:
-#' - a `InputsModel` argument of class \emph{InputsModel} must be followed by a `RunOptions` argument of class \emph{RunOptions}, a `InputsCrit` argument of class \emph{InputsCrit} and a `CalibOptions` of class \emph{CalibOptions}
-#' - - a `InputsModel` argument of class \emph{GRiwrmInputsModel} must be followed by a `RunOptions` argument of class \emph{GRiwrmRunOptions}, a `InputsCrit` argument of class \emph{GRiwrmInputsCrit} and a `CalibOptions` of class \emph{GRiwrmCalibOptions}
+#' - a `InputsModel` argument of class \emph{InputsModel} must be followed by a
+#' `RunOptions` argument of class \emph{RunOptions}, a `InputsCrit` argument of
+#' class \emph{InputsCrit} and a `CalibOptions` of class \emph{CalibOptions}
+#' - a `InputsModel` argument of class \emph{GRiwrmInputsModel} must be followed
+#' by a `RunOptions` argument of class \emph{GRiwrmRunOptions}, a `InputsCrit`
+#' argument of class \emph{GRiwrmInputsCrit} and a `CalibOptions` of class
+#' \emph{GRiwrmCalibOptions}
 #'
 #' See the vignettes for examples.
 #'
-#' @return Depending on the class of `InputsModel` argument (respectively `InputsModel` and `GRiwrmInputsModel` object), the returned value is respectively:
-#' - a `InputsCrit` object (See [airGR::CreateInputsCrit])
-#' - a `GRiwrmInputsCrit` object which is a [list] of `InputsCrit` objects with one item per modeled sub-catchment
+#' @return Depending on the class of `InputsModel` argument (respectively
+#' `InputsModel` and `GRiwrmInputsModel` object), the returned value is respectively:
+#' - a `OutputsCalib` object (See [airGR::Calibration] for more details on this object)
+#' - a `GRiwrmOutputsCalib` object which is a [list] of `OutputsCalib` objects with
+#' one item per modeled sub-catchment
 #'
 #' @rdname Calibration
 #' @seealso [CreateGRiwrm()], [CreateInputsModel.GRiwrm()], [CreateInputsCrit()], [CreateCalibOptions()]

R/utils.Calibration.R

+#' Create InputsCrit for De Lavenne regularization
+#'
+#' Internal function that run [airGR::CreateInputsCrit_Lavenne] on-the-fly with a priori upstream
+#' sub-catchment parameters grabbed during network calibration process.
+#'
+#' @param id [character] the id of the current sub-catchment
+#' @param OutputsModel \[GRiwrmOutputsModel\] object with simulation results of upstream sub-catchments run with calibrated parameters
+#' @param InputsCrit \[InputsCritLavenneFunction\] object internally created by [CreateInputsCrit.GRiwrmInputsModel]
+#'
+#' @return \[InputsCrit\] object with De Lavenne regularization
+#' @import airGR
+#' @noRd
+#'
+getInputsCrit_Lavenne <- function(id, OutputsModel, InputsCrit) {
+  if (!inherits(InputsCrit[[id]], "InputsCritLavenneFunction")) {
+    stop("'InputsCrit[[id]]' must be of class InputsCritLavenneFunction")
+  }
+  AprioriId <- attr(InputsCrit[[id]], "AprioriId")
+  AprCelerity <- attr(InputsCrit[[id]], "AprCelerity")
+  Lavenne_FUN <- attr(InputsCrit[[id]], "Lavenne_FUN")
+  AprParamR <- OutputsModel[[AprioriId]]$RunOptions$Param
+  if (!inherits(OutputsModel[[AprioriId]], "SD")) {
+    # Add Celerity parameter if apriori is an upstream node
+    AprParamR <- c(AprCelerity, AprParamR)
+  }
+  featMod <- attr(InputsCrit[[id]], "model")
+  if (featMod$hasX4) {
+    AprParamR[featMod$iX4] <- AprParamR[featMod$iX4] * featMod$X4Ratio
+  }
+  AprParamR <- AprParamR[featMod$indexParamUngauged]
+  message("A priori parameters from node ", AprioriId, ": ", paste(round(AprParamR, 3), collapse = ", "))
+  AprCrit <- ErrorCrit(InputsCrit[[AprioriId]], OutputsModel[[AprioriId]])$CritValue
+  return(Lavenne_FUN(AprParamR, AprCrit))
+}
+
+
+#' Reduce a GRiwrm list object (InputsModel, RunOptions...) for a reduced network
+#'
+#' @param griwrm See [CreateGRiwrm])
+#' @param obj Either a *GRiwrmInputsModel*, *GRiwrmOptions*... object
+#'
+#' @return The object containing only nodes of the reduced model
+#' @noRd
+reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
+  objAttributes <- attributes(obj)
+  obj <- lapply(obj, function(o) {
+    if (o$id %in% griwrm$id && any(!is.na(griwrm$model[griwrm$id == o$id]))) {
+      o
+    } else {
+      NULL
+    }
+  })
+  obj[sapply(obj, is.null)] <- NULL
+  objAttributes$names <- names(obj)
+  attributes(obj) <- objAttributes
+  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
+#' @importFrom dplyr "%>%"
+#' @importFrom rlang .data
+#'
+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 donor gauged node
+  griwrm <- attr(InputsModel, "GRiwrm")
+  donorIds <- griwrm$id[!is.na(griwrm$donor) & griwrm$donor == GaugedId]
+  gDonor <- griwrm %>% dplyr::filter(.data$id %in% donorIds)
+  # Add upstream nodes for routing upstream flows
+  upNodes <- griwrm %>%
+    dplyr::filter(.data$down %in% gDonor$id,
+                  !.data$id %in% gDonor$id) %>%
+    dplyr::mutate(model = ifelse(!is.na(.data$model), NA, .data$model))
+  upIds <- upNodes$id
+  g <- rbind(upNodes, gDonor)
+  # Set downstream nodes
+  g$down[!g$down %in% g$id] <- NA
+
+  ### 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 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)) {
+      # 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 InputsModel for airGR::Calibration checks
+  class(InputsModel) <- c("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)])})
+  )
+}
+
+
+#' RunModel for a sub-network of ungauged nodes
+#'
+#' The function simulates a network with one set of parameters
+#' shared with ungauged nodes inside the basin.
+#'
+#' @details
+#' The network should contains only one gauged station at downstream and other
+#' nodes can be direct injection or ungauged nodes.
+#'
+#' This function works as functions similar to [airGR::RunModel_GR4J] except that
+#' `InputsModel` is a *GRiwrmInputsModel* containing the network of ungauged nodes
+#' and direct injection in the basin.
+#'
+#' `Param` is adjusted for each sub-basin using the method developed by
+#' Lobligeois (2014) for GR models.
+#'
+#' @references Lobligeois, Florent. Mieux connaître la distribution spatiale des
+#' pluies améliore-t-il la modélisation des crues ? Diagnostic sur 181 bassins
+#' versants français. Phdthesis, AgroParisTech, 2014.
+#' <https://pastel.hal.science/tel-01134990/document>
+#'
+#' @inheritParams airGR::RunModel
+#' @param ouput.all [logical] if `TRUE` returns the output of [RunModel.GRiwrm],
+#' returns the `OutputsModel` of the downstream node otherwise
+#'
+#' @inherit RunModel.GRiwrmInputsModel return return
+#' @noRd
+RunModel_Ungauged <- function(InputsModel, RunOptions, Param, output.all = FALSE) {
+  InputsModel$FUN_MOD <- NULL
+  donor <- RunOptions$id
+  # Compute Param for each sub-basin
+  P <- lapply(InputsModel, function(IM) {
+    if (IM$id == donor) return(Param)
+    if (IM$isReservoir) {
+      return(IM$FixedParam)
+    }
+    return(transferGRparams(InputsModel, Param, donor, IM$id))
+  })
+  OM <- suppressMessages(
+    RunModel.GRiwrmInputsModel(InputsModel, attr(RunOptions, "GRiwrmRunOptions"), P)
+  )
+  if (output.all) {
+    return(OM)
+  } else {
+    return(OM[[length(OM)]])
+  }
+}
+
+#' Transfer GR parameters from one donor sub-basin to a receiver sub-basin
+#'
+#' This function is used by `Calibration.GRiwrmInputsModel` for transferring parameters
+#' to ungauged nodes and
+#'
+#' @details
+#' `donor` and `receiver` nodes should have the same GR model with the same snow
+#' module configuration.
+#'
+#' The transfer takes care of:
+#' - the presence/absence of hydraulic routing parameters between the donor and the receiver
+#' - the transformationof the X4 parameters of GR models
+#'
+#' @param InputsModel A *GRiwrmInputsModel* object (See [CreateInputsModel.GRiwrm])
+#' @param Param [numeric] vector of GR model parameters
+#' @param donor [character] id of the node which gives its parameters
+#' @param receiver [character] id of the node which receives the parameters from the donor
+#' @param default_param [numeric] vector of GR model parameters if parameters are missing from the donor
+#'
+#' @return A [numeric] [vector] with transferred parameters
+#' @export
+#'
+transferGRparams <- function(InputsModel, Param, donor, receiver, default_param = NULL) {
+  missing_params <- setdiff(InputsModel[[receiver]]$model$indexParamUngauged,
+                            InputsModel[[donor]]$model$indexParamUngauged)
+  if (length(missing_params) > 0) {
+    if (is.null(default_param)) {
+      stop("Missing parameters in transfer between nodes '",
+           donor, "' and '", receiver, "'\n",
+           "Fix the missing parameters with the argument `FixedParam` of `CreateCalibOptions`")
+    }
+    max_params <- max(
+      max(InputsModel[[receiver]]$model$indexParamUngauged),
+      max(InputsModel[[donor]]$model$indexParamUngauged)
+    )
+    if (length(default_param) < max_params) {
+      stop("Error in parameter transfer between nodes '", donor, "' and '",
+           receiver, "'\n`default_params` should have a minimum length of ", max_params)
+    }
+    Param2 <- rep(as.numeric(NA), length(InputsModel[[receiver]]$model$indexParamUngauged))
+    Param2[InputsModel[[donor]]$model$indexParamUngauged] <- Param
+    Param2[missing_params] <- default_param[missing_params]
+    Param <- Param2
+  }
+
+  p <- Param
+  if (length(Param) > length(InputsModel[[receiver]]$model$indexParamUngauged)) {
+    # Transfer from intermediate node to upstream node
+    p <- p[InputsModel[[receiver]]$model$indexParamUngauged]
+  }
+
+  if (InputsModel[[receiver]]$model$hasX4) {
+    donor_area <- InputsModel[[donor]]$BasinAreas[length(InputsModel[[donor]]$BasinAreas)]
+    receiver_area <- InputsModel[[receiver]]$BasinAreas[length(InputsModel[[receiver]]$BasinAreas)]
+    p[InputsModel[[receiver]]$model$iX4] <- max(
+      Param[InputsModel[[donor]]$model$iX4] *
+        (receiver_area / donor_area) ^ 0.3,
+      0.5
+    )
+  }
+  return(p)
+}
+
+#' Extract calibrated parameters
+#'
+#' Extract [list] of parameters from the output of [Calibration.GRiwrmInputsModel]
+#' which can be directly used as argument `Param` of [RunModel.GRiwrmInputsModel]
+#' and [RunModel.Supervisor].
+#'
+#' @details
+#' See vignettes and example of [RunModel_Reservoir] for examples of use.
+#'
+#' @param x A *GRiwrmOutputsModel* object returned by [Calibration.GRiwrmInputsModel]
+#'
+#' @return A named [list] of [numeric] [vector] containing the calibrated parameters
+#' of each modelled node.
+#'
+#' @seealso [Calibration], [RunModel.GRiwrmInputsModel], [RunModel.Supervisor]
+#'
+#' @export
+#'
+extractParam <- function(x) {
+  stopifnot(inherits(x, "GRiwrmOutputsCalib"))
+  lapply(x, "[[", "ParamFinalR")
+}

airGRiwrm.Rproj

@@ -22,3 +22,5 @@ PackageInstallArgs: --no-multiarch --with-keep.source
 PackageBuildBinaryArgs: --no-multiarch
 PackageCheckArgs: --no-multiarch
 PackageRoxygenize: rd,collate,namespace
+
+SpellingDictionary: en_US

man-examples/RunModel_Reservoir.R

@@ -74,7 +74,8 @@ OC <- Calibration(
 )
 
 # Model parameters
-Param <- lapply(OC, "[[", "ParamFinalR")
+Param <- extractParam(OC)
+str(Param)
 
 # Running simulation
 OutputsModel <- RunModel(InputsModel, RunOptions, Param)

man/Calibration.Rd

@@ -34,25 +34,31 @@ Calibration(InputsModel, ...)
 \item{...}{further arguments passed to \link[airGR:Calibration]{airGR::Calibration}, see details}
 }
 \value{
-Depending on the class of \code{InputsModel} argument (respectively \code{InputsModel} and \code{GRiwrmInputsModel} object), the returned value is respectively:
+Depending on the class of \code{InputsModel} argument (respectively
+\code{InputsModel} and \code{GRiwrmInputsModel} object), the returned value is respectively:
 \itemize{
-\item a \code{InputsCrit} object (See \link[airGR:CreateInputsCrit]{airGR::CreateInputsCrit})
-\item a \code{GRiwrmInputsCrit} object which is a \link{list} of \code{InputsCrit} objects with one item per modeled sub-catchment
+\item a \code{OutputsCalib} object (See \link[airGR:Calibration]{airGR::Calibration} for more details on this object)
+\item a \code{GRiwrmOutputsCalib} object which is a \link{list} of \code{OutputsCalib} objects with
+one item per modeled sub-catchment
 }
 }
 \description{
-Calibration algorithm that optimizes the error criterion selected as objective function using the provided functions.
+Calibration algorithm that optimizes the error criterion selected as objective
+function using the provided functions.
 }
 \details{
-This function can be used either for a catchment (with an \emph{InputsModel} object) or for a network (with a \emph{GRiwrmInputsModel} object)
+This function can be used either for a catchment (with an \emph{InputsModel}
+object) or for a network (with a \emph{GRiwrmInputsModel} object)
 
 Argument classes should be consistent to the usage:
 \itemize{
-\item a \code{InputsModel} argument of class \emph{InputsModel} must be followed by a \code{RunOptions} argument of class \emph{RunOptions}, a \code{InputsCrit} argument of class \emph{InputsCrit} and a \code{CalibOptions} of class \emph{CalibOptions}
-\item 
-\itemize{
-\item a \code{InputsModel} argument of class \emph{GRiwrmInputsModel} must be followed by a \code{RunOptions} argument of class \emph{GRiwrmRunOptions}, a \code{InputsCrit} argument of class \emph{GRiwrmInputsCrit} and a \code{CalibOptions} of class \emph{GRiwrmCalibOptions}
-}
+\item a \code{InputsModel} argument of class \emph{InputsModel} must be followed by a
+\code{RunOptions} argument of class \emph{RunOptions}, a \code{InputsCrit} argument of
+class \emph{InputsCrit} and a \code{CalibOptions} of class \emph{CalibOptions}
+\item a \code{InputsModel} argument of class \emph{GRiwrmInputsModel} must be followed
+by a \code{RunOptions} argument of class \emph{GRiwrmRunOptions}, a \code{InputsCrit}
+argument of class \emph{GRiwrmInputsCrit} and a \code{CalibOptions} of class
+\emph{GRiwrmCalibOptions}
 }
 
 See the vignettes for examples.

man/RunModel_Reservoir.Rd

@@ -131,7 +131,8 @@ OC <- Calibration(
 )
 
 # Model parameters
-Param <- lapply(OC, "[[", "ParamFinalR")
+Param <- extractParam(OC)
+str(Param)
 
 # Running simulation
 OutputsModel <- RunModel(InputsModel, RunOptions, Param)

man/extractParam.Rd

+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.Calibration.R
+\name{extractParam}
+\alias{extractParam}
+\title{Extract calibrated parameters}
+\usage{
+extractParam(x)
+}
+\arguments{
+\item{x}{A \emph{GRiwrmOutputsModel} object returned by \link{Calibration.GRiwrmInputsModel}}
+
+\item{...}{Not used, only present for S3 class compatibility}
+}
+\value{
+A named \link{list} of \link{numeric} \link{vector} containing the calibrated parameters
+of each modelled node.
+}
+\description{
+Extract \link{list} of parameters from the output of \link{Calibration.GRiwrmInputsModel}
+which can be directly used as argument \code{Param} of \link{RunModel.GRiwrmInputsModel}
+and \link{RunModel.Supervisor}.
+}
+\details{
+See vignettes and example of \link{RunModel_Reservoir} for examples of use.
+}
+\seealso{
+\link{Calibration}, \link{RunModel.GRiwrmInputsModel}, \link{RunModel.Supervisor}
+}

man/plot.OutputsModelReservoir.Rd

@@ -96,7 +96,8 @@ OC <- Calibration(
 )
 
 # Model parameters
-Param <- lapply(OC, "[[", "ParamFinalR")
+Param <- extractParam(OC)
+str(Param)
 
 # Running simulation
 OutputsModel <- RunModel(InputsModel, RunOptions, Param)

man/transferGRparams.Rd

 % Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/Calibration.GRiwrmInputsModel.R
+% Please edit documentation in R/utils.Calibration.R
 \name{transferGRparams}
 \alias{transferGRparams}
 \title{Transfer GR parameters from one donor sub-basin to a receiver sub-basin}

vignettes/V02_Calibration_SD_model.Rmd

@@ -134,7 +134,6 @@ The **airGR** calibration process is applied on each node of the `GRiwrm` networ
 ```{r Calibration}
 OutputsCalib <- suppressWarnings(
   Calibration(InputsModel, RunOptions, InputsCrit, CalibOptions))
-ParamV02 <- sapply(OutputsCalib, "[[", "ParamFinalR")
 ```
 
 ## Run the model with the optimized model parameters
@@ -143,7 +142,7 @@ ParamV02 <- sapply(OutputsCalib, "[[", "ParamFinalR")
 OutputsModels <- RunModel(
   InputsModel,
   RunOptions = RunOptions,
-  Param = ParamV02
+  Param = extractParam(OutputsCalib)
 )
 ```
 

vignettes/seinebasin/V03_First_Calibration.Rmd

@@ -59,7 +59,7 @@ OutputsCalib <- Calibration(InputsModel, RunOptions, InputsCrit, CalibOptions)
 Now that the model is calibrated, we can run it with the optimized parameter values:
 
 ```{r RunModel}
-ParamMichel <- sapply(griwrm$id, function(x) {OutputsCalib[[x]]$Param})
+ParamMichel <- extractParam(OutputsCalib)
 
 OutputsModels <- RunModel(
   InputsModel,

vignettes/seinebasin/V05_Open-loop_influenced_flow_calibration.Rmd

@@ -113,7 +113,7 @@ OutputsCalib <- Calibration(InputsModel3, RunOptions, InputsCrit, CalibOptions)
 Now that the model is calibrated, we can run it with the optimized parameter values:
 
 ```{r RunModel}
-Param5 <- sapply(griwrm3$id, function(x) {OutputsCalib[[x]]$Param})
+Param5 <- extractParam(OutputsCalib)
 
 OutputsModels3 <- RunModel(
   InputsModel3,

vignettes/seinebasin/V05b_Open-loop_influenced_flow_calibration_GR6J.Rmd

@@ -115,7 +115,7 @@ OutputsCalib <- Calibration(InputsModel3, RunOptions, InputsCrit, CalibOptions)
 Now that the model is calibrated, we can run it with the optimized parameter values:
 
 ```{r RunModel}
-Param5 <- sapply(griwrm3$id, function(x) {OutputsCalib[[x]]$Param})
+Param5 <- extractParam(OutputsCalib)
 
 OutputsModels3 <- RunModel(
   InputsModel3,