Resolve "Feature request: feedback control"

Closes #19 (closed)

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()

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)

R/RunModel.Supervisor.R

 #' 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.

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)

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()
 }