CreateInputsModel.GRiwrm.R

#' Create InputsModel object for a GRIWRM network
#'
#' @param x GRiwrm object describing the diagram of the semi-distributed model, see \code{[GRiwrm]}.
#' @param DatesR Vector of POSIXt observation time steps.
#' @param Precip Matrix or data frame of numeric containing precipitation in mm. Column names correspond to node IDs.
#' @param PotEvap Matrix or data frame of numeric containing potential evaporation in mm. Column names correspond to node IDs.
#' @param Qobs Matrix or data frame of numeric containing potential observed flow in mm. Column names correspond to node IDs.
#' @param verbose (optional) boolean indicating if the function is run in verbose mode or not, default = \code{TRUE}
#' @param ... further arguments passed to \code{\link[airGR]{CreateInputsModel}}.
#'
#' @return GRiwrmInputsModel object equivalent to airGR InputsModel object for a semi-distributed model (See \code{\link[airGR]{CreateInputsModel}})
#' @export
CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, verbose = TRUE, ...) {

  InputsModel <- CreateEmptyGRiwrmInputsModel()
  Qobs[is.na(Qobs)] <- -99 # airGRCreateInputsModel doesn't accept NA values

  for(id in getNodeRanking(x)) {
    if(verbose) cat("CreateInputsModel.griwrm: Treating sub-basin", id, "...\n")
    InputsModel[[id]] <- CreateOneGRiwrmInputsModel(
      id, x, DatesR,Precip[,id], PotEvap[,id], Qobs, ...
    )
  }
  return(InputsModel)
}


#' Create an empty InputsModel object for GRIWRM nodes
#'
#' @return \emph{GRiwrmInputsModel} empty object
CreateEmptyGRiwrmInputsModel <- function() {
  InputsModel <- list()
  class(InputsModel) <- append(class(InputsModel), "GRiwrmInputsModel")
  return(InputsModel)
}


#' Create one InputsModel for a GRIWRM node
#'
#' @param id string of the node identifier
#' @param griwrm See \code{[GRiwrm]}.
#' @param DatesR vector of dates required to create the GR model and CemaNeige module inputs.
#' @param Precip time series of potential evapotranspiration (catchment average) (mm/time step).
#' @param PotEvap time series of potential evapotranspiration (catchment average) (mm/time step).
#' @param Qobs Matrix or data frame of numeric containing observed flow (mm/time step). Column names correspond to node IDs.
##'
#' @return \emph{InputsModel} object for one.
CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, Precip, PotEvap, Qobs) {
  node <- griwrm[griwrm$id == id,]
  FUN_MOD <- griwrm$model[griwrm$id == id]

  # Set hydraulic parameters
  UpstreamNodes <- griwrm$id[griwrm$down == id & !is.na(griwrm$down)]
  Qupstream <- NULL
  LengthHydro <- NULL
  BasinAreas <- NULL

  if(length(UpstreamNodes) > 0) {
    # Sub-basin with hydraulic routing
    Qupstream <- Qobs[ , UpstreamNodes, drop=FALSE]
    LengthHydro <- griwrm$length[griwrm$id %in% UpstreamNodes]
    names(LengthHydro) <- UpstreamNodes
    BasinAreas <- c(
        griwrm$area[griwrm$id %in% UpstreamNodes],
        node$area - sum(griwrm$area[griwrm$id %in% UpstreamNodes], na.rm = TRUE)
    )
    names(BasinAreas) <- c(UpstreamNodes, id)
  }

  # Set model inputs with the airGR function
  InputsModel <- CreateInputsModel(
    FUN_MOD,
    DatesR = DatesR,
    Precip = Precip,
    PotEvap = PotEvap,
    Qupstream = Qupstream,
    LengthHydro = LengthHydro,
    BasinAreas = BasinAreas
  )

  # Add Identifiers of connected nodes in order to be able to update them with simulated flows
  InputsModel$id <- id
  if(length(UpstreamNodes) > 0) {
    InputsModel$UpstreamNodes <- UpstreamNodes
    InputsModel$UpstreamIsRunoff <- !is.na(griwrm$model[match(UpstreamNodes, griwrm$id)])
  }
  # Add the model function
  InputsModel$FUN_MOD <- FUN_MOD

  return(InputsModel)
}