Forked from HYCAR-Hydro / airGR
Source project has a limited visibility.
Calibration_Michel.R 18.66 KiB
Calibration_Michel <- function(InputsModel, 
                               RunOptions, 
                               InputsCrit, 
                               CalibOptions,
                               FUN_MOD, 
                               FUN_CRIT,           # deprecated
                               FUN_TRANSFO = NULL, 
                               verbose = TRUE) {
  FUN_MOD  <- match.fun(FUN_MOD)
  if (!missing(FUN_CRIT)) {
    FUN_CRIT <- match.fun(FUN_CRIT)
  if (!is.null(FUN_TRANSFO)) {
    FUN_TRANSFO <- match.fun(FUN_TRANSFO)
  ##_____Arguments_check_____________________________________________________________________
  if (!inherits(InputsModel, "InputsModel")) {
    stop("InputsModel must be of class 'InputsModel'")
  if (!inherits(RunOptions, "RunOptions")) {
    stop("RunOptions must be of class 'RunOptions'")
  if (!inherits(InputsCrit, "InputsCrit")) {
    stop("InputsCrit must be of class 'InputsCrit'")
  if (inherits(InputsCrit, "Multi")) {
    stop("InputsCrit must be of class 'Single' or 'Compo'")
  if (inherits(InputsCrit, "Single")) {
    listVarObs <- InputsCrit$varObs
  if (inherits(InputsCrit, "Compo")) {
    listVarObs <- sapply(InputsCrit, FUN = "[[", "varObs")
  if ("SCA" %in% listVarObs & !"Gratio" %in% RunOptions$Outputs_Cal) {
    warning("Missing 'Gratio' is automatically added to 'Output_Cal' in 'RunOptions' as it is necessary in the objective function for comparison with SCA")
    RunOptions$Outputs_Cal <- c(RunOptions$Outputs_Cal, "Gratio")
  if ("SWE" %in% listVarObs & !"SnowPack" %in% RunOptions$Outputs_Cal) {
    warning("Missing 'SnowPack' is automatically added to 'Output_Cal' in 'RunOptions' as it is necessary in the objective function for comparison with SWE")
    RunOptions$Outputs_Cal <- c(RunOptions$Outputs_Cal, "SnowPack")
  if (!inherits(CalibOptions, "CalibOptions")) {
    stop("CalibOptions must be of class 'CalibOptions'")
  if (!inherits(CalibOptions, "HBAN")) {
    stop("CalibOptions must be of class 'HBAN' if Calibration_Michel is used")
  if (!missing(FUN_CRIT)) {
    warning("argument 'FUN_CRIT' is deprecated. The error criterion function is now automatically get from the 'InputsCrit' object")
  ##_check_FUN_TRANSFO
  if (is.null(FUN_TRANSFO)) {
    if (identical(FUN_MOD, RunModel_GR4H         )) {
      FUN_TRANSFO <- TransfoParam_GR4H
    if (identical(FUN_MOD, RunModel_GR4J         )) {
      FUN_TRANSFO <- TransfoParam_GR4J
    if (identical(FUN_MOD, RunModel_GR5J         )) {
      FUN_TRANSFO <- TransfoParam_GR5J
    if (identical(FUN_MOD, RunModel_GR6J         )) {
      FUN_TRANSFO <- TransfoParam_GR6J
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
} if (identical(FUN_MOD, RunModel_GR2M )) { FUN_TRANSFO <- TransfoParam_GR2M } if (identical(FUN_MOD, RunModel_GR1A )) { FUN_TRANSFO <- TransfoParam_GR1A } if (identical(FUN_MOD, RunModel_CemaNeige )) { if (inherits(CalibOptions, "hysteresis")) { FUN_TRANSFO <- TransfoParam_CemaNeigeHyst } else { FUN_TRANSFO <- TransfoParam_CemaNeige } } if (identical(FUN_MOD, RunModel_CemaNeigeGR4J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) { if (identical(FUN_MOD, RunModel_CemaNeigeGR4J)) { FUN1 <- TransfoParam_GR4J } if (identical(FUN_MOD, RunModel_CemaNeigeGR5J)) { FUN1 <- TransfoParam_GR5J } if (identical(FUN_MOD, RunModel_CemaNeigeGR6J)) { FUN1 <- TransfoParam_GR6J } if (inherits(CalibOptions, "hysteresis")) { FUN2 <- TransfoParam_CemaNeigeHyst } else { FUN2 <- TransfoParam_CemaNeige } if (inherits(CalibOptions, "hysteresis")) { FUN_TRANSFO <- function(ParamIn, Direction) { Bool <- is.matrix(ParamIn) if (!Bool) { ParamIn <- rbind(ParamIn) } ParamOut <- NA * ParamIn NParam <- ncol(ParamIn) ParamOut[, 1:(NParam-4)] <- FUN1(ParamIn[, 1:(NParam-4)], Direction) ParamOut[, (NParam-3):NParam ] <- FUN2(ParamIn[, (NParam-3):NParam ], Direction) if (!Bool) { ParamOut <- ParamOut[1, ] } return(ParamOut) } } else { FUN_TRANSFO <- function(ParamIn, Direction) { Bool <- is.matrix(ParamIn) if (!Bool) { ParamIn <- rbind(ParamIn) } ParamOut <- NA * ParamIn NParam <- ncol(ParamIn) ParamOut[, 1:(NParam-2)] <- FUN1(ParamIn[, 1:(NParam-2)], Direction) ParamOut[, (NParam-1):NParam ] <- FUN2(ParamIn[, (NParam-1):NParam ], Direction) if (!Bool) { ParamOut <- ParamOut[1, ] } return(ParamOut) } } } if (is.null(FUN_TRANSFO)) { stop("FUN_TRANSFO was not found (in Calibration function)") } } ##_variables_initialisation ParamFinalR <- NULL ParamFinalT <- NULL