CreateInputsCrit.GRiwrmInputsModel.R

#' @rdname CreateInputsCrit
#' @import airGR
#' @importFrom utils tail read.table
#' @export
CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
                                               FUN_CRIT = ErrorCrit_NSE,
                                               RunOptions,
                                               Obs,
                                               AprioriIds = NULL,
                                               k = 0.15,
                                               AprCelerity = 1,
                                               ...) {
  # Parameter checks

  # We invoke the mandatory arguments here for avoiding
  # a messy error message on "get(x)" if an argument is missing
  # We also list all arguments in order to check arguments even in "..."
  arguments <- c(as.list(environment()), list(...))

  # Checking argument classes
  lVars2Check <- list(InputsModel = "GRiwrmInputsModel",
                      RunOptions = "GRiwrmRunOptions",
                      Obs = c("matrix", "data.frame"))
  lapply(names(lVars2Check), function(argName) {
    b <- sapply(lVars2Check[[argName]], function(argClass) {
      !inherits(get(argName), argClass)
    })
    if (all(b)) {
      stop(sprintf("'%s' must be of class %s", argName, paste(lVars2Check[[argName]], collapse = " or ")))
    }
  })

  if (!is.null(AprioriIds)) {
    AprioriIds <- unlist(AprioriIds)
    if (!is.character(AprioriIds) || is.null(names(AprioriIds))) {
      stop("Argument 'AprioriIds' must be a named list or a named vector of characters")
    }
    if (length(unique(names(AprioriIds))) != length(names(AprioriIds))) {
      stop("Each name of AprioriIds items must be unique: duplicate entry detected")
    }
    if ("Weights" %in% names(arguments)) {
      stop("Argument 'Weights' cannot be used when using Lavenne criterion")
    }
    if (!"transfo" %in% names(arguments)) {
      stop("Argument 'transfo' must be defined when using Lavenne criterion (Using \"sqrt\" is recommended)")
    }
    lapply(names(AprioriIds), function(id) {
      if (!id %in% names(InputsModel)) {
        stop("'Each item of names(AprioriIds) must be an id of a modelled node:",
             " the id \"", id ,"\" is not in the list of the modelled nodes")
      }
      if (!AprioriIds[id] %in% names(InputsModel)) {
        stop("'Each item of AprioriIds must be an id of a modelled node:",
             " the id \"", AprioriIds[id] ,"\" is not in the list of the modelled nodes")
      }
      if (! isNodeDownstream(InputsModel, AprioriIds[id], id)) {
        stop("'AprioriIds': the node \"", AprioriIds[id],
             "\" is not upstream the node \"", id,"\"")
      }
      if (InputsModel[[AprioriIds[id]]]$isUngauged &
          InputsModel[[AprioriIds[id]]]$gaugedId == id) {
        stop("'AprioriIds': the node \"", AprioriIds[id],
             "\" is an ungauged upstream node of the node \"", id,"\"")
      }
      if (!identical(InputsModel[[id]]$FUN_MOD, InputsModel[[AprioriIds[id]]]$FUN_MOD)) {
        stop("'AprioriIds': the node \"", AprioriIds[id],
             "\" must use the same hydrological model as the node \"", id,"\"")
      }
    })
  }