CreateCalibOptions.R 13.14 KiB
CreateCalibOptions <- function(FUN_MOD,
                               FUN_CALIB = Calibration_Michel,
                               FUN_TRANSFO = NULL,
                               IsHyst = FALSE,
                               FixedParam = NULL,
                               SearchRanges = NULL,
                               StartParamList = NULL,
                               StartParamDistrib = NULL) {
  ObjectClass <- NULL
    FUN_MOD     <- match.fun(FUN_MOD)
    FUN_CALIB   <- match.fun(FUN_CALIB)
    if(!is.null(FUN_TRANSFO)) {
      FUN_TRANSFO <- match.fun(FUN_TRANSFO)
    if (!is.logical(IsHyst) | length(IsHyst) != 1L) {
      stop("'IsHyst' must be a logical of length 1")
    ##check_FUN_MOD
    BOOL <- FALSE
    if (identical(FUN_MOD, RunModel_GR4H)) {
      ObjectClass <- c(ObjectClass, "GR4H")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_GR4J)) {
      ObjectClass <- c(ObjectClass, "GR4J")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_GR5J)) {
      ObjectClass <- c(ObjectClass, "GR5J")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_GR6J)) {
      ObjectClass <- c(ObjectClass, "GR6J")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_GR2M)) {
      ObjectClass <- c(ObjectClass, "GR2M")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_GR1A)) {
      ObjectClass <- c(ObjectClass, "GR1A")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_CemaNeige)) {
      ObjectClass <- c(ObjectClass, "CemaNeige")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_CemaNeigeGR4J)) {
      ObjectClass <- c(ObjectClass, "CemaNeigeGR4J")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_CemaNeigeGR5J)) {
      ObjectClass <- c(ObjectClass, "CemaNeigeGR5J")
      BOOL <- TRUE
    if (identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
      ObjectClass <- c(ObjectClass, "CemaNeigeGR6J")
      BOOL <- TRUE
	if (IsHyst) {
	  ObjectClass <- c(ObjectClass, "hysteresis")
    if (!BOOL) {
      stop("incorrect 'FUN_MOD' for use in 'CreateCalibOptions'")
      return(NULL)
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
##check_FUN_CALIB BOOL <- FALSE if (identical(FUN_CALIB, Calibration_Michel)) { ObjectClass <- c(ObjectClass, "HBAN") BOOL <- TRUE } if (!BOOL) { stop("incorrect 'FUN_CALIB' for use in 'CreateCalibOptions'") return(NULL) } ##check_FUN_TRANSFO if (is.null(FUN_TRANSFO)) { ##_set_FUN1 if (identical(FUN_MOD, RunModel_GR4H)) { FUN1 <- TransfoParam_GR4H } if (identical(FUN_MOD, RunModel_GR4J) | identical(FUN_MOD, RunModel_CemaNeigeGR4J)) { FUN1 <- TransfoParam_GR4J } if (identical(FUN_MOD, RunModel_GR5J) | identical(FUN_MOD, RunModel_CemaNeigeGR5J)) { FUN1 <- TransfoParam_GR5J } if (identical(FUN_MOD, RunModel_GR6J) | identical(FUN_MOD, RunModel_CemaNeigeGR6J)) { FUN1 <- TransfoParam_GR6J } if (identical(FUN_MOD, RunModel_GR2M)) { FUN1 <- TransfoParam_GR2M } if (identical(FUN_MOD, RunModel_GR1A)) { FUN1 <- TransfoParam_GR1A } if (identical(FUN_MOD, RunModel_CemaNeige)) { if (IsHyst) { FUN1 <- TransfoParam_CemaNeigeHyst } else { FUN1 <- TransfoParam_CemaNeige } } if (is.null(FUN1)) { stop("'FUN1' was not found") return(NULL) } ##_set_FUN2 if (IsHyst) { FUN2 <- TransfoParam_CemaNeigeHyst } else { FUN2 <- TransfoParam_CemaNeige } ##_set_FUN_TRANSFO if (sum(ObjectClass %in% c("GR4H", "GR4J", "GR5J", "GR6J", "GR2M", "GR1A", "CemaNeige")) > 0) { FUN_TRANSFO <- FUN1 } else { if (IsHyst) { 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, ]
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
} return(ParamOut) } } else { FUN_TRANSFO <- function(ParamIn, Direction) { Bool <- is.matrix(ParamIn) if (!Bool) { ParamIn <- rbind(ParamIn) } ParamOut <- NA * ParamIn NParam <- ncol(ParamIn) if (NParam <= 3) { ParamOut[, 1:(NParam - 2)] <- FUN1(cbind(ParamIn[, 1:(NParam - 2)]), Direction) } else { 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") return(NULL) } ##NParam if ("GR4H" %in% ObjectClass) { NParam <- 4 } if ("GR4J" %in% ObjectClass) { NParam <- 4 } if ("GR5J" %in% ObjectClass) { NParam <- 5 } if ("GR6J" %in% ObjectClass) { NParam <- 6 } if ("GR2M" %in% ObjectClass) { NParam <- 2 } if ("GR1A" %in% ObjectClass) { NParam <- 1 } if ("CemaNeige" %in% ObjectClass) { NParam <- 2 } if ("CemaNeigeGR4J" %in% ObjectClass) { NParam <- 6 } if ("CemaNeigeGR5J" %in% ObjectClass) { NParam <- 7 } if ("CemaNeigeGR6J" %in% ObjectClass) { NParam <- 8 } if (IsHyst) { NParam <- NParam + 2 } ##check_FixedParam if (is.null(FixedParam)) { FixedParam <- rep(NA, NParam) } else { if (!is.vector(FixedParam)) {