diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R index 3dfbe106e0bbf59801dc637b59c2c00e775d34f7..3b62b7761caa3166ec8000ece5591de648991702 100644 --- a/R/Calibration.GRiwrmInputsModel.R +++ b/R/Calibration.GRiwrmInputsModel.R @@ -30,7 +30,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, IM <- UpdateQsimUpstream(IM, RunOptions[[IM$id]]$IndPeriod_Run, OutputsModel) } - OutputsCalib[[IM$id]] <- Calibration.InputsModel( + OutputsCalib[[IM$id]] <- Calibration( InputsModel = IM, RunOptions = RunOptions[[IM$id]], InputsCrit = InputsCrit[[IM$id]], @@ -41,7 +41,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, if(useUpstreamQsim) { # Run the model for the sub-basin OutputsModel[[IM$id]] <- RunModel( - InputsModel = IM, + x = IM, RunOptions = RunOptions[[IM$id]], Param = OutputsCalib[[IM$id]]$ParamFinalR ) diff --git a/R/CreateInputsCrit.GRiwrmInputsModel.R b/R/CreateInputsCrit.GRiwrmInputsModel.R index 56af942644ae37dcfba799109b45c1215fe1395c..889600818f88276667a706f849023ef5b7f5fd4e 100644 --- a/R/CreateInputsCrit.GRiwrmInputsModel.R +++ b/R/CreateInputsCrit.GRiwrmInputsModel.R @@ -1,11 +1,14 @@ #' Create \emph{GRiwrmInputsCrit} object for **airGRiwrm**. +#' +#' This function does the same operations as [airGR::CreateInputsCrit] for all sub-basins of the GRiwrm model. +#' #' @param InputsModel object of class \emph{GRiwrmInputsModel}, see \code{\link{CreateInputsModel.GRiwrm}} for details. #' @param FUN_CRIT \[function (atomic or list)\] error criterion function (e.g. \code{\link[airGR]{ErrorCrit_RMSE}}, \code{\link[airGR]{ErrorCrit_NSE}}) #' @param RunOptions object of class \emph{GRiwrmRunOptions}, see \code{[CreateRunOptions.GRiwrm]} for details. #' @param Qobs matrix or data frame containing observed flows. Column names correspond to nodes ID -#' @param ... further arguments passed to \code{\link[airGR]{CreateInputsCrit}}. +#' @param ... further arguments passed to [airGR::CreateInputsCrit]. #' -#' @return Object of class \emph{GRiwrmInputsCrit} +#' @return Object of class \emph{GRiwrmInputsCrit} which is a list of `airGR::InputsCrit` objects (See [airGR::CreateInputsCrit]) #' @export CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel, FUN_CRIT = airGR::ErrorCrit_NSE, diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index 2b541e7975aa5c2b67da4adb473e65cb5d4618e5..94fc5bcacfda9298015f49a8c57be6cb9a66efb0 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -26,10 +26,12 @@ CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, ...) { #' Create an empty InputsModel object for **airGRiwrm** nodes #' +#' @param griwrm [GRiwrm] object +#' #' @return \emph{GRiwrmInputsModel} empty object CreateEmptyGRiwrmInputsModel <- function() { InputsModel <- list() - class(InputsModel) <- append(class(InputsModel), "GRiwrmInputsModel") + class(InputsModel) <- c("GRiwrmInputsModel", class(InputsModel)) return(InputsModel) } @@ -79,6 +81,7 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, Precip, PotEvap, Qobs # Add Identifiers of connected nodes in order to be able to update them with simulated flows InputsModel$id <- id + InputsModel$down <- node$down if(length(UpstreamNodes) > 0) { InputsModel$UpstreamNodes <- UpstreamNodes InputsModel$UpstreamIsRunoff <- !is.na(griwrm$model[match(UpstreamNodes, griwrm$id)]) diff --git a/R/CreateInputsModel.R b/R/CreateInputsModel.R index 618463f62379c4fd3a641bb64a95124700bd8790..6d17ddabaec16154568cc04297fcb6508ade9ad0 100644 --- a/R/CreateInputsModel.R +++ b/R/CreateInputsModel.R @@ -1,4 +1,6 @@ -#' Create InputsModel object for either **airGR** or **airGRiwrm** +#' Generic function for creating `InputsModel` object for either **airGR** or **airGRiwrm** +#' +#' See the methods [CreateInputsModel.GRiwrm] for **airGRiwrm** and [CreateInputsModel.default] for **airGR**. #' #' @param x First parameter determining which InputsModel object is created #' @param ... further arguments passed to or from other methods. diff --git a/R/CreateSupervisor.R b/R/CreateSupervisor.R index 5c1758123f1cc02e67cec435d91154a383ddb386..d0ad354b773e2fb01305b4be3469e56c76b7f16f 100644 --- a/R/CreateSupervisor.R +++ b/R/CreateSupervisor.R @@ -1,6 +1,29 @@ -CreateSupervisor <- function(griwrm) { +#' Create a Supervisor for handling regulation in a model +#' +#' @param InputsModel `GRiwrmInputsModel` The inputs of the basin model +#' +#' @return +#' @export +#' +#' @examples +#' data(Severn) +#' nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")] +#' nodes$distance_downstream <- nodes$distance_downstream * 1000 # Conversion km -> m +#' nodes$model <- "RunModel_GR4J" +#' griwrm <- GRiwrm(nodes, list(id = "gauge_id", down = "downstream_id", length = "distance_downstream")) +#' BasinsObs <- Severn$BasinsObs +#' DatesR <- BasinsObs[[1]]$DatesR +#' PrecipTot <- cbind(sapply(BasinsObs, function(x) {x$precipitation})) +#' PotEvapTot <- cbind(sapply(BasinsObs, function(x) {x$peti})) +#' Qobs <- cbind(sapply(BasinsObs, function(x) {x$discharge_spec})) +#' Precip <- ConvertMeteoSD(griwrm, PrecipTot) +#' PotEvap <- ConvertMeteoSD(griwrm, PotEvapTot) +#' InputsModel <- CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs) +#' sv <- CreateSupervisor(InputsModel) +CreateSupervisor <- function(InputsModel) { # Create Supervisor environment in the parent of GlobalEnv e <- new.env(parent = parent.env(globalenv())) + class(e) <- c("Supervisor", class(e)) # Hidden variable to detect which environment it is e$.isSupervisor <- "3FJKmDcJ4snDbVBg" @@ -8,14 +31,31 @@ CreateSupervisor <- function(griwrm) { # Add pointer to itself in order to assign variable from function environment e$supervisor <- e - e$griwrm <- griwrm + # Copy of the InputsModel + e$InputsModel <- InputsModel + e$OutputsModel <- list() # Controller list - e$Controllers <- list() - class(e$Controllers) <- c("Controllers", class(e$Controllers)) + e$controllers <- list() + class(e$controllers) <- c("Controllers", class(e$controllers)) - # Copy functions + # Copy functions to be used enclosed in the Supervisor environment e$createController <- createController environment(e$createController) <- e + e$getDataFromLocation <- getDataFromLocation + environment(getDataFromLocation) <- e + e$setDataToLocation <- setDataToLocation + environment(setDataToLocation) <- e + e$doSupervision <- doSupervision + environment(doSupervision) <- e + + # Time steps handling: these data are provided by RunModel + # Index of the current time steps in the modelled time series between 1 and length(RunOptions$Ind_Period) + e$ts.index <- NA + # Index of the time step preceding RunOptions$Ind_Period + e$ts.index0 <- NA + # Date/Time of the current time step (For controller calculations based on date) + e$ts.date <- NULL + return(e) } diff --git a/R/RunModel.GR.R b/R/RunModel.GR.R index bb0f7b1e6371ae7b696536039349754d43fd8fdb..e4fa5562d1a4cfc884e85b2f5f0728e5d3d73470 100644 --- a/R/RunModel.GR.R +++ b/R/RunModel.GR.R @@ -1,13 +1,15 @@ #' Run rainfall-runoff part of a sub-basin model #' #' @inherit airGR::RunModel +#' @param x `InputsModel` used as `InputsModel` parameter for [airGR::RunModel] #' @param ... further arguments passed to or from other methods #' #' @export #' -RunModel.GR <- function(InputsModel, RunOptions, Param, ...) { +RunModel.GR <- function(x, RunOptions, Param, ...) { + message("RunModel.GR") - if (inherits(InputsModel, "SD")) { + if (inherits(x, "SD")) { # Lag model take one parameter at the beginning of the vector iFirstParamRunOffModel <- 2 } else { @@ -15,7 +17,7 @@ RunModel.GR <- function(InputsModel, RunOptions, Param, ...) { iFirstParamRunOffModel <- 1 } - FUN_MOD <- match.fun(InputsModel$FUN_MOD) - FUN_MOD(InputsModel = InputsModel, RunOptions = RunOptions, + FUN_MOD <- match.fun(x$FUN_MOD) + FUN_MOD(x, RunOptions = RunOptions, Param = Param[iFirstParamRunOffModel:length(Param)]) } diff --git a/R/RunModel.GRiwrmInputsModel.R b/R/RunModel.GRiwrmInputsModel.R index 59a4edf54abaa6d86dec65eca9d3def1db0ccd42..a3d894d28db021f1155a5c07225fbc2cd215b06a 100644 --- a/R/RunModel.GRiwrmInputsModel.R +++ b/R/RunModel.GRiwrmInputsModel.R @@ -1,35 +1,36 @@ #' RunModel function for GRiwrmInputsModel object #' -#' @param InputsModel object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details. +#' @param x object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details. #' @param RunOptions object of class \emph{GRiwrmRunOptions}, see \code{[CreateRunOptions.GRiwrm]} for details. #' @param Param list of parameter. The list item names are the IDs of the sub-basins. Each item is a vector of numerical parameters. #' @param ... Mandatory for S3 method signature function compatibility with generic. #' #' @return \emph{GRiwrmOutputsModel} object which is a list of \emph{OutputsModel} objects (See \code{\link[airGR]{RunModel}}) for each node of the semi-distributed model. #' @export -RunModel.GRiwrmInputsModel <- function(InputsModel, RunOptions, Param, ...) { +RunModel.GRiwrmInputsModel <- function(x, RunOptions, Param, ...) { + message("RunModel.GRiwrmInputsModel") # Run runoff model for each sub-basin - OutputsModel <- lapply(X = InputsModel, FUN = function(IM) { - RunModel.GR(InputsModel = IM, + OutputsModel <- lapply(X = x, FUN = function(IM) { + RunModel.GR(IM, RunOptions = RunOptions[[IM$id]], Param = Param[[IM$id]]) }) class(OutputsModel) <- append(class(OutputsModel), "GRiwrmOutputsModel") # Loop over sub-basin using SD model - for(id in getSD_Ids(InputsModel)) { - IM <- InputsModel[[id]] + for(id in getSD_Ids(x)) { + IM <- x[[id]] message("RunModel.GRiwrmInputsModel: Treating sub-basin ", id, "...") - # Update InputsModel$Qupstream with simulated upstream flows + # Update x$Qupstream with simulated upstream flows if(any(IM$UpstreamIsRunoff)) { IM <- UpdateQsimUpstream(IM, RunOptions[[id]]$IndPeriod_Run, OutputsModel) } # Run the SD model for the sub-basin OutputsModel[[id]] <- RunModel.SD( - InputsModel = IM, + IM, RunOptions = RunOptions[[id]], Param = Param[[id]], OutputsModel[[id]] diff --git a/R/RunModel.InputsModel.R b/R/RunModel.InputsModel.R index 83affc57243f387b1818f4a9b0c367634c5eb81d..c2c290aabbb66188eea542c927b8c4682f803d86 100644 --- a/R/RunModel.InputsModel.R +++ b/R/RunModel.InputsModel.R @@ -1,11 +1,12 @@ #' Wrapper for \code{\link[airGR]{RunModel}} for one sub-basin. #' #' @inherit airGR::RunModel +#' @param x `InputsModel` used as `InputsModel` parameter for [airGR::RunModel] #' @param ... Further arguments for compatibility with S3 method #' @export -RunModel.InputsModel <- function(InputsModel, RunOptions, Param, FUN_MOD = NULL, ...) { +RunModel.InputsModel <- function(x, RunOptions, Param, FUN_MOD = NULL, ...) { if(is.null(FUN_MOD)) { - FUN_MOD <- InputsModel$FUN_MOD + FUN_MOD <- x$FUN_MOD } - airGR::RunModel(InputsModel, RunOptions, Param, FUN_MOD) + airGR::RunModel(x, RunOptions, Param, FUN_MOD) } diff --git a/R/RunModel.R b/R/RunModel.R index 48eb869b2e34f923398fe72301ef4b76df2bf5c7..a3ea4600cbb87eb55c6b3d3e05dcd367797e6a0b 100644 --- a/R/RunModel.R +++ b/R/RunModel.R @@ -1,10 +1,11 @@ #' RunModel function for both **airGR** InputsModel and GRiwrmInputsModel object #' -#' @param InputsModel object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}. See \code{\link{CreateInputsModel}} for details +#' @param x object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}. See \code{\link{CreateInputsModel}} for details #' @param ... further arguments passed to or from other methods #' #' @return Either a [list] of OutputsModel object (for GRiwrmInputsModel) or an OutputsModel object (for InputsModel) #' @export -RunModel <- function(InputsModel, ...) { - UseMethod("RunModel", InputsModel) +RunModel <- function(x, ...) { + message("RunModel") + UseMethod("RunModel", x) } diff --git a/R/RunModel.SD.R b/R/RunModel.SD.R index 4b5cb67681258a07254ff1a9bcfaa09e5f6468ef..95f661f1b32aa1882b299d9d4f08ddbe55c14292 100644 --- a/R/RunModel.SD.R +++ b/R/RunModel.SD.R @@ -1,13 +1,15 @@ #' Run SD Model from run-off model outputs #' #' @inheritParams airGR::RunModel_Lag +#' @param x `InputsModel` used as `InputsModel` parameter for [airGR::RunModel] #' @param OutputsModel `OutputsModel` object returned by a GR model by [airGR::RunModel] #' @param ... further arguments passed to or from other methods #' #' @return `OutputsModel` object. See [airGR::RunModel_Lag] #' @export #' -RunModel.SD <- function(InputsModel, RunOptions, Param, OutputsModel, ...) { - InputsModel$OutputsModel <- OutputsModel - RunModel_Lag(InputsModel, RunOptions, Param[1]) +RunModel.SD <- function(x, RunOptions, Param, OutputsModel, ...) { + message("RunModel.SD") + x$OutputsModel <- OutputsModel + RunModel_Lag(x, RunOptions = RunOptions, Param = Param[1]) } diff --git a/R/RunModel.Supervisor.R b/R/RunModel.Supervisor.R new file mode 100644 index 0000000000000000000000000000000000000000..7e74f2ab9ef0cbce9e52965629d95697ce77be70 --- /dev/null +++ b/R/RunModel.Supervisor.R @@ -0,0 +1,45 @@ +#' RunModel function for GRiwrmInputsModel object +#' +#' @param InputsModel object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details. +#' @param RunOptions object of class \emph{GRiwrmRunOptions}, see \code{[CreateRunOptions.GRiwrm]} for details. +#' @param Param list of parameter. The list item names are the IDs of the sub-basins. Each item is a vector of numerical parameters. +#' @param ... Mandatory for S3 method signature function compatibility with generic. +#' +#' @return \emph{GRiwrmOutputsModel} object which is a list of \emph{OutputsModel} objects (See \code{\link[airGR]{RunModel}}) for each node of the semi-distributed model. +#' @export +RunModel.Supervisor <- function(x, RunOptions, Param, ...) { + + x$ts.index0 <- sapply(RunOptions, function(x) { + x$IndPeriod_Run[1] - 1 + }) + + # Run runoff model for each sub-basin + OutputsModel <- lapply(X = x$InputsModel, FUN = function(IM) { + RunModel.GR(IM, + RunOptions = RunOptions[[IM$id]], + Param = Param[[IM$id]]) + }) + class(OutputsModel) <- append(class(OutputsModel), "GRiwrmOutputsModel") + + # Loop over time steps + # Loop over sub-basin using SD model + for(id in getSD_Ids(x$InputsModel)) { + IM <- x$InputsModel[[id]] + message("RunModel.GRiwrmInputsModel: Treating sub-basin ", id, "...") + + # Update InputsModel$Qupstream with simulated upstream flows + if(any(IM$UpstreamIsRunoff)) { + IM <- UpdateQsimUpstream(IM, RunOptions[[id]]$IndPeriod_Run, OutputsModel) + } + + # Run the SD model for the sub-basin + OutputsModel[[id]] <- RunModel.SD( + IM, + RunOptions = RunOptions[[id]], + Param = Param[[id]], + OutputsModel[[id]] + ) + + } + return(OutputsModel) +} diff --git a/R/createController.R b/R/createController.R index 35d503f8bebefecf98b5419c7b3a522a78dd37cd..c25a448ad845b17d5f00a30ab5091f1e2b60ac5d 100644 --- a/R/createController.R +++ b/R/createController.R @@ -39,10 +39,10 @@ createController <- function(ctrl.id, Y, U, FUN){ if(exists(".isSupervisor") && .isSupervisor == "3FJKmDcJ4snDbVBg") { # Function called from Supervisor environment environment(ctrlr$FUN) <- supervisor - if(!is.null(supervisor$Controllers[[ctrl.id]])) { + if(!is.null(supervisor$controllers[[ctrl.id]])) { warning("Controller '", ctrl.id, "' already exists in the supervisor: overwriting") } - supervisor$Controllers[[ctrl.id]] <- ctrlr + supervisor$controllers[[ctrl.id]] <- ctrlr message("The controller has been added to the supervisor") invisible(ctrlr) } else { diff --git a/R/utils.R b/R/utils.R index 5c258de8ac2e3cdfa317fa4003b0b158dfab4b6a..fe2f0f9d095e9238272b7d72ae0f3262e1d1bbaa 100644 --- a/R/utils.R +++ b/R/utils.R @@ -13,3 +13,50 @@ getSD_Ids <- function(InputsModel) { }) names(InputsModel)[bSDs] } + + +#' Retrieve data in the model for the current time steps +#' +#' This function should be call inside a Supervisor +#' +#' @param loc location of the data +#' +#' @return [numeric] retrieved data at the location +getDataFromLocation <- function(loc) { + if(grep("\\[[0-9]+\\]$", loc)) { + stop("Reaching output of other controller is not implemented yet") + } else { + supervisor$OutputsModel[[loc]]$Qsim[supervisor$ts.index - 1] + } +} + + +#' Write data to model input for the current time step +#' +#' @param control [list] A row of the `U` [data.frame] from a `Controller` +#' +#' @return [NULL] +setDataToLocation <- function(control) { + node <- InputsModel[[control$loc]]$down + # ! Qupstream contains warm up period and run period => the index is shifted + supervisor$InputsModel[[node]]$Qupstream[ts.index0[node] + ts.index, control$loc] <- control$v +} + + +#' Do the supervision for the current time step +#' +#' @param supervisor `Supervisor` (See [CreateSupervisor]) +#' +#' @return [NULL] +doSupervision <- function(controllers) { + for(id in names(controllers)) { + ctrlr <- controllers[[id]] + # Read Y from locations in the model + supervisor$controllers[[id]]$Y$v <- sapply(controllers[[id]]$Y$loc, getDataFromLocation) + # Run logic + supervisor$controllers[[id]]$U$v <- sapply(controllers[[id]]$Y$v, controllers[[id]]$FUN) + # Write U to locations in the model + sapply(controllers[[id]]$U, setDataToLocation) + } + return() +} diff --git a/vignettes/V02_Calibration_SD_model.Rmd b/vignettes/V02_Calibration_SD_model.Rmd index 319e3dc32282aae5281c0eb41f8a01bbfa177654..f064dc93a8a16a29a5c8322735dc23e0d0b33b92 100644 --- a/vignettes/V02_Calibration_SD_model.Rmd +++ b/vignettes/V02_Calibration_SD_model.Rmd @@ -128,7 +128,7 @@ ParamMichel <- sapply(griwrm$id, function(x) {OutputsCalib[[x]]$Param}) ```{r RunModel} OutputsModels <- RunModel( - InputsModel = InputsModel, + InputsModel, RunOptions = RunOptions, Param = ParamMichel ) diff --git a/vignettes/V03_Open-loop_influenced_flow.Rmd b/vignettes/V03_Open-loop_influenced_flow.Rmd index d98c37bbd68f21933ba35c3eb3f80b8b2fd0a663..7437f0fbc03a8f3945ede80d7d90bc5a8337e6e3 100644 --- a/vignettes/V03_Open-loop_influenced_flow.Rmd +++ b/vignettes/V03_Open-loop_influenced_flow.Rmd @@ -89,7 +89,7 @@ Param_OL <- sapply(griwrm$id, function(x) {OC_OL[[x]]$Param}) ```{r RunModel} OM_OL <- RunModel( - InputsModel = IM_OL, + IM_OL, RunOptions = RunOptions, Param = Param_OL )