Failed to fetch fork details. Try again later.
-
Delaigue Olivier authored1132f2b1
Forked from
HYCAR-Hydro / airGR
Source project has a limited visibility.
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