From 6f4fbd26ba01c1215d03d4940d2356d19d73edf3 Mon Sep 17 00:00:00 2001 From: David <david.dorchies@inrae.fr> Date: Wed, 31 Jul 2024 16:54:33 +0200 Subject: [PATCH] feat: add extractParam Also moved calibration tools into utils.Calibration.R Refs #86 --- NAMESPACE | 1 + R/Calibration.GRiwrmInputsModel.R | 258 ---------------- R/Calibration.R | 23 +- R/utils.Calibration.R | 280 ++++++++++++++++++ airGRiwrm.Rproj | 2 + man-examples/RunModel_Reservoir.R | 3 +- man/Calibration.Rd | 26 +- man/RunModel_Reservoir.Rd | 3 +- man/extractParam.Rd | 28 ++ man/plot.OutputsModelReservoir.Rd | 3 +- man/transferGRparams.Rd | 2 +- vignettes/V02_Calibration_SD_model.Rmd | 3 +- .../seinebasin/V03_First_Calibration.Rmd | 2 +- ..._Open-loop_influenced_flow_calibration.Rmd | 2 +- ...-loop_influenced_flow_calibration_GR6J.Rmd | 2 +- 15 files changed, 354 insertions(+), 284 deletions(-) create mode 100644 R/utils.Calibration.R create mode 100644 man/extractParam.Rd diff --git a/NAMESPACE b/NAMESPACE index 2b8b415..2477df9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,6 +44,7 @@ export(CreateSupervisor) export(RunModel) export(RunModel_Reservoir) export(as.Qm3s) +export(extractParam) export(getAllNodesProperties) export(getNoSD_Ids) export(getNodeProperties) diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R index f15ec95..ccbe11e 100644 --- a/R/Calibration.GRiwrmInputsModel.R +++ b/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) -} diff --git a/R/Calibration.R b/R/Calibration.R index e7f1e51..2b3e7d0 100644 --- a/R/Calibration.R +++ b/R/Calibration.R @@ -1,8 +1,10 @@ #' 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()] diff --git a/R/utils.Calibration.R b/R/utils.Calibration.R new file mode 100644 index 0000000..4478cf9 --- /dev/null +++ b/R/utils.Calibration.R @@ -0,0 +1,280 @@ +#' 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") +} diff --git a/airGRiwrm.Rproj b/airGRiwrm.Rproj index 5a4f1ea..b01898b 100644 --- a/airGRiwrm.Rproj +++ b/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 diff --git a/man-examples/RunModel_Reservoir.R b/man-examples/RunModel_Reservoir.R index 85a6764..463f5b6 100644 --- a/man-examples/RunModel_Reservoir.R +++ b/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) diff --git a/man/Calibration.Rd b/man/Calibration.Rd index db45f92..2ad183a 100644 --- a/man/Calibration.Rd +++ b/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. diff --git a/man/RunModel_Reservoir.Rd b/man/RunModel_Reservoir.Rd index ee504de..01b2b3d 100644 --- a/man/RunModel_Reservoir.Rd +++ b/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) diff --git a/man/extractParam.Rd b/man/extractParam.Rd new file mode 100644 index 0000000..6af7bb0 --- /dev/null +++ b/man/extractParam.Rd @@ -0,0 +1,28 @@ +% 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} +} diff --git a/man/plot.OutputsModelReservoir.Rd b/man/plot.OutputsModelReservoir.Rd index b0796d9..ad08bbe 100644 --- a/man/plot.OutputsModelReservoir.Rd +++ b/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) diff --git a/man/transferGRparams.Rd b/man/transferGRparams.Rd index fec8b21..c1f2584 100644 --- a/man/transferGRparams.Rd +++ b/man/transferGRparams.Rd @@ -1,5 +1,5 @@ % 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} diff --git a/vignettes/V02_Calibration_SD_model.Rmd b/vignettes/V02_Calibration_SD_model.Rmd index 5146c63..56d0496 100644 --- a/vignettes/V02_Calibration_SD_model.Rmd +++ b/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) ) ``` diff --git a/vignettes/seinebasin/V03_First_Calibration.Rmd b/vignettes/seinebasin/V03_First_Calibration.Rmd index e42071d..00475ce 100644 --- a/vignettes/seinebasin/V03_First_Calibration.Rmd +++ b/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, diff --git a/vignettes/seinebasin/V05_Open-loop_influenced_flow_calibration.Rmd b/vignettes/seinebasin/V05_Open-loop_influenced_flow_calibration.Rmd index bcc36f6..6268522 100644 --- a/vignettes/seinebasin/V05_Open-loop_influenced_flow_calibration.Rmd +++ b/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, diff --git a/vignettes/seinebasin/V05b_Open-loop_influenced_flow_calibration_GR6J.Rmd b/vignettes/seinebasin/V05b_Open-loop_influenced_flow_calibration_GR6J.Rmd index ae4f1ea..52331ff 100644 --- a/vignettes/seinebasin/V05b_Open-loop_influenced_flow_calibration_GR6J.Rmd +++ b/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, -- GitLab