diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index 94fc5bcacfda9298015f49a8c57be6cb9a66efb0..2d8ad3bacab51ea6d3186409929bc39a01b2166d 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -26,8 +26,6 @@ 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() diff --git a/R/CreateSupervisor.R b/R/CreateSupervisor.R index d0ad354b773e2fb01305b4be3469e56c76b7f16f..660f4ecba09c9e98a2ebf4511d81e52822a90ab0 100644 --- a/R/CreateSupervisor.R +++ b/R/CreateSupervisor.R @@ -2,7 +2,7 @@ #' #' @param InputsModel `GRiwrmInputsModel` The inputs of the basin model #' -#' @return +#' @return `Supervisor` object #' @export #' #' @examples @@ -10,7 +10,10 @@ #' 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")) +#' 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})) @@ -42,12 +45,6 @@ CreateSupervisor <- function(InputsModel) { # 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) diff --git a/R/RunModel.Supervisor.R b/R/RunModel.Supervisor.R index 7e74f2ab9ef0cbce9e52965629d95697ce77be70..f847ecca30a3cf0019d11973b6d98f00851e1603 100644 --- a/R/RunModel.Supervisor.R +++ b/R/RunModel.Supervisor.R @@ -1,6 +1,6 @@ #' RunModel function for GRiwrmInputsModel object #' -#' @param InputsModel object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details. +#' @param x object of class `Supervisor`, see [CreateSupervisor] 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. diff --git a/R/createController.R b/R/createController.R index c25a448ad845b17d5f00a30ab5091f1e2b60ac5d..1d63a3d0ecc2813a5aa8dc251c8d8e4bf08050b1 100644 --- a/R/createController.R +++ b/R/createController.R @@ -9,6 +9,7 @@ #' for the previous time step and returns calculated `U`. These `U` will then be applied #' at their location for the current time step of calculation of the model. #' +#' @param supervisor `Supervisor` object, see [CreateSupervisor] #' @param ctrl.id [character] id of the controller (see Details) #' @param Y [character] location of the controlled and/or measured variables in the model. See [createControl] #' @param U [character] location of the command variables in the model. See [createControl] @@ -18,11 +19,13 @@ #' @export #' #' @examples +#' # First create a Supervisor from a model +#' example("CreateSupervisor") #' # A controller which usually releases 0.1 m3/s and provides #' # extra release if the downstream flow is below 0.5 m3/s #' logicDamRelease <- function(Y) max(0.5 - Y[1], 0.1) -#' createController("DamRelease", Y = c("54001"), U = c("54095"), FUN = logicDamRelease) -createController <- function(ctrl.id, Y, U, FUN){ +#' createController(sv, "DamRelease", Y = c("54001"), U = c("54095"), FUN = logicDamRelease) +createController <- function(supervisor, ctrl.id, Y, U, FUN){ if(!is.character(ctrl.id)) stop("Parameter `ctrl.id` should be character") @@ -36,19 +39,14 @@ createController <- function(ctrl.id, Y, U, FUN){ ) class(ctrlr) <- c("Controller", class(ctrlr)) - if(exists(".isSupervisor") && .isSupervisor == "3FJKmDcJ4snDbVBg") { - # Function called from Supervisor environment - environment(ctrlr$FUN) <- supervisor - if(!is.null(supervisor$controllers[[ctrl.id]])) { - warning("Controller '", ctrl.id, "' already exists in the supervisor: overwriting") - } - supervisor$controllers[[ctrl.id]] <- ctrlr - message("The controller has been added to the supervisor") - invisible(ctrlr) - } else { - # Return the object to the user - return(ctrlr) + # Function called from Supervisor environment + environment(ctrlr$FUN) <- supervisor + if(!is.null(supervisor$controllers[[ctrl.id]])) { + warning("Controller '", ctrl.id, "' already exists in the supervisor: overwriting") } + supervisor$controllers[[ctrl.id]] <- ctrlr + message("The controller has been added to the supervisor") + invisible(ctrlr) } #' Create a list of controls for command (U) and controlled variables (Y) diff --git a/R/utils.R b/R/utils.R index fe2f0f9d095e9238272b7d72ae0f3262e1d1bbaa..f2fac0a8ad679df4c64acaa2f24475da21786d35 100644 --- a/R/utils.R +++ b/R/utils.R @@ -5,7 +5,7 @@ #' @return [character] IDs of the sub-basins using SD model #' getSD_Ids <- function(InputsModel) { - if(!inherits(InputsModel, "GRiwrmInputsModel")) { + if (!inherits(InputsModel, "GRiwrmInputsModel")) { stop("Argument `InputsModel` should be of class GRiwrmInputsModel") } bSDs <- sapply(InputsModel, function (IM) { @@ -20,10 +20,11 @@ getSD_Ids <- function(InputsModel) { #' This function should be call inside a Supervisor #' #' @param loc location of the data +#' @param supervisor `Supervisor` (See [CreateSupervisor]) #' #' @return [numeric] retrieved data at the location -getDataFromLocation <- function(loc) { - if(grep("\\[[0-9]+\\]$", loc)) { +getDataFromLocation <- function(loc, supervisor) { + if (grep("\\[[0-9]+\\]$", loc)) { stop("Reaching output of other controller is not implemented yet") } else { supervisor$OutputsModel[[loc]]$Qsim[supervisor$ts.index - 1] @@ -34,12 +35,14 @@ getDataFromLocation <- function(loc) { #' Write data to model input for the current time step #' #' @param control [list] A row of the `U` [data.frame] from a `Controller` +#' @param supervisor `Supervisor` (See [CreateSupervisor]) #' #' @return [NULL] -setDataToLocation <- function(control) { - node <- InputsModel[[control$loc]]$down +setDataToLocation <- function(control, supervisor) { + node <- supervisor$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 + supervisor$InputsModel[[node]]$Qupstream[supervisor$ts.index0[node] + supervisor$ts.index, control$loc] <- + control$v } @@ -48,15 +51,17 @@ setDataToLocation <- function(control) { #' @param supervisor `Supervisor` (See [CreateSupervisor]) #' #' @return [NULL] -doSupervision <- function(controllers) { - for(id in names(controllers)) { - ctrlr <- controllers[[id]] +doSupervision <- function(supervisor) { + for (id in names(supervisor$controllers)) { + ctrlr <- supervisor$controllers[[id]] # Read Y from locations in the model - supervisor$controllers[[id]]$Y$v <- sapply(controllers[[id]]$Y$loc, getDataFromLocation) + supervisor$controllers[[id]]$Y$v <- + sapply(supervisor$controllers[[id]]$Y$loc, getDataFromLocation, supervisor = supervisor) # Run logic - supervisor$controllers[[id]]$U$v <- sapply(controllers[[id]]$Y$v, controllers[[id]]$FUN) + supervisor$controllers[[id]]$U$v <- + sapply(supervisor$controllers[[id]]$Y$v, supervisor$controllers[[id]]$FUN) # Write U to locations in the model - sapply(controllers[[id]]$U, setDataToLocation) + sapply(supervisor$controllers[[id]]$U, setDataToLocation, supervisor = supervisor) } return() }