Commit 1a3d61d4 authored by Dorchies David's avatar Dorchies David
Browse files

fix: note and warning in check

Refs #19
Showing with 35 additions and 37 deletions
+35 -37
...@@ -26,8 +26,6 @@ CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, ...) { ...@@ -26,8 +26,6 @@ CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, ...) {
#' Create an empty InputsModel object for **airGRiwrm** nodes #' Create an empty InputsModel object for **airGRiwrm** nodes
#' #'
#' @param griwrm [GRiwrm] object
#'
#' @return \emph{GRiwrmInputsModel} empty object #' @return \emph{GRiwrmInputsModel} empty object
CreateEmptyGRiwrmInputsModel <- function() { CreateEmptyGRiwrmInputsModel <- function() {
InputsModel <- list() InputsModel <- list()
......
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
#' #'
#' @param InputsModel `GRiwrmInputsModel` The inputs of the basin model #' @param InputsModel `GRiwrmInputsModel` The inputs of the basin model
#' #'
#' @return #' @return `Supervisor` object
#' @export #' @export
#' #'
#' @examples #' @examples
...@@ -10,7 +10,10 @@ ...@@ -10,7 +10,10 @@
#' nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")] #' nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")]
#' nodes$distance_downstream <- nodes$distance_downstream * 1000 # Conversion km -> m #' nodes$distance_downstream <- nodes$distance_downstream * 1000 # Conversion km -> m
#' nodes$model <- "RunModel_GR4J" #' 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 #' BasinsObs <- Severn$BasinsObs
#' DatesR <- BasinsObs[[1]]$DatesR #' DatesR <- BasinsObs[[1]]$DatesR
#' PrecipTot <- cbind(sapply(BasinsObs, function(x) {x$precipitation})) #' PrecipTot <- cbind(sapply(BasinsObs, function(x) {x$precipitation}))
...@@ -42,12 +45,6 @@ CreateSupervisor <- function(InputsModel) { ...@@ -42,12 +45,6 @@ CreateSupervisor <- function(InputsModel) {
# Copy functions to be used enclosed in the Supervisor environment # Copy functions to be used enclosed in the Supervisor environment
e$createController <- createController e$createController <- createController
environment(e$createController) <- e 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 # 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) # Index of the current time steps in the modelled time series between 1 and length(RunOptions$Ind_Period)
......
#' RunModel function for GRiwrmInputsModel object #' 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 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 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. #' @param ... Mandatory for S3 method signature function compatibility with generic.
......
...@@ -9,6 +9,7 @@ ...@@ -9,6 +9,7 @@
#' for the previous time step and returns calculated `U`. These `U` will then be applied #' 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. #' 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 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 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] #' @param U [character] location of the command variables in the model. See [createControl]
...@@ -18,11 +19,13 @@ ...@@ -18,11 +19,13 @@
#' @export #' @export
#' #'
#' @examples #' @examples
#' # First create a Supervisor from a model
#' example("CreateSupervisor")
#' # A controller which usually releases 0.1 m3/s and provides #' # A controller which usually releases 0.1 m3/s and provides
#' # extra release if the downstream flow is below 0.5 m3/s #' # extra release if the downstream flow is below 0.5 m3/s
#' logicDamRelease <- function(Y) max(0.5 - Y[1], 0.1) #' logicDamRelease <- function(Y) max(0.5 - Y[1], 0.1)
#' createController("DamRelease", Y = c("54001"), U = c("54095"), FUN = logicDamRelease) #' createController(sv, "DamRelease", Y = c("54001"), U = c("54095"), FUN = logicDamRelease)
createController <- function(ctrl.id, Y, U, FUN){ createController <- function(supervisor, ctrl.id, Y, U, FUN){
if(!is.character(ctrl.id)) stop("Parameter `ctrl.id` should be character") if(!is.character(ctrl.id)) stop("Parameter `ctrl.id` should be character")
...@@ -36,19 +39,14 @@ createController <- function(ctrl.id, Y, U, FUN){ ...@@ -36,19 +39,14 @@ createController <- function(ctrl.id, Y, U, FUN){
) )
class(ctrlr) <- c("Controller", class(ctrlr)) class(ctrlr) <- c("Controller", class(ctrlr))
if(exists(".isSupervisor") && .isSupervisor == "3FJKmDcJ4snDbVBg") { # Function called from Supervisor environment
# Function called from Supervisor environment environment(ctrlr$FUN) <- supervisor
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")
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)
} }
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) #' Create a list of controls for command (U) and controlled variables (Y)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
#' @return [character] IDs of the sub-basins using SD model #' @return [character] IDs of the sub-basins using SD model
#' #'
getSD_Ids <- function(InputsModel) { getSD_Ids <- function(InputsModel) {
if(!inherits(InputsModel, "GRiwrmInputsModel")) { if (!inherits(InputsModel, "GRiwrmInputsModel")) {
stop("Argument `InputsModel` should be of class GRiwrmInputsModel") stop("Argument `InputsModel` should be of class GRiwrmInputsModel")
} }
bSDs <- sapply(InputsModel, function (IM) { bSDs <- sapply(InputsModel, function (IM) {
...@@ -20,10 +20,11 @@ getSD_Ids <- function(InputsModel) { ...@@ -20,10 +20,11 @@ getSD_Ids <- function(InputsModel) {
#' This function should be call inside a Supervisor #' This function should be call inside a Supervisor
#' #'
#' @param loc location of the data #' @param loc location of the data
#' @param supervisor `Supervisor` (See [CreateSupervisor])
#' #'
#' @return [numeric] retrieved data at the location #' @return [numeric] retrieved data at the location
getDataFromLocation <- function(loc) { getDataFromLocation <- function(loc, supervisor) {
if(grep("\\[[0-9]+\\]$", loc)) { if (grep("\\[[0-9]+\\]$", loc)) {
stop("Reaching output of other controller is not implemented yet") stop("Reaching output of other controller is not implemented yet")
} else { } else {
supervisor$OutputsModel[[loc]]$Qsim[supervisor$ts.index - 1] supervisor$OutputsModel[[loc]]$Qsim[supervisor$ts.index - 1]
...@@ -34,12 +35,14 @@ getDataFromLocation <- function(loc) { ...@@ -34,12 +35,14 @@ getDataFromLocation <- function(loc) {
#' Write data to model input for the current time step #' Write data to model input for the current time step
#' #'
#' @param control [list] A row of the `U` [data.frame] from a `Controller` #' @param control [list] A row of the `U` [data.frame] from a `Controller`
#' @param supervisor `Supervisor` (See [CreateSupervisor])
#' #'
#' @return [NULL] #' @return [NULL]
setDataToLocation <- function(control) { setDataToLocation <- function(control, supervisor) {
node <- InputsModel[[control$loc]]$down node <- supervisor$InputsModel[[control$loc]]$down
# ! Qupstream contains warm up period and run period => the index is shifted # ! 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) { ...@@ -48,15 +51,17 @@ setDataToLocation <- function(control) {
#' @param supervisor `Supervisor` (See [CreateSupervisor]) #' @param supervisor `Supervisor` (See [CreateSupervisor])
#' #'
#' @return [NULL] #' @return [NULL]
doSupervision <- function(controllers) { doSupervision <- function(supervisor) {
for(id in names(controllers)) { for (id in names(supervisor$controllers)) {
ctrlr <- controllers[[id]] ctrlr <- supervisor$controllers[[id]]
# Read Y from locations in the model # 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 # 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 # Write U to locations in the model
sapply(controllers[[id]]$U, setDataToLocation) sapply(supervisor$controllers[[id]]$U, setDataToLocation, supervisor = supervisor)
} }
return() return()
} }
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment