CreateCalibOptions.R

CreateCalibOptions <- function(FUN_MOD, FUN_CALIB = Calibration_Michel, FUN_TRANSFO = NULL, FixedParam = NULL,SearchRanges = NULL,
                               StartParamList = NULL, StartParamDistrib = NULL){


  ObjectClass <- NULL;

  ##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(!BOOL){ stop("incorrect FUN_MOD for use in CreateCalibOptions \n"); return(NULL); } 

  ##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 \n"); 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)                                             ){ FUN1 <- TransfoParam_CemaNeige; }
      if(is.null(FUN1)){ stop("FUN1 was not found \n"); return(NULL);  }
      ##_set_FUN2
      FUN2 <- TransfoParam_CemaNeige;
      ##_set_FUN_TRANSFO
      if(sum(ObjectClass %in% c("GR4H","GR4J","GR5J","GR6J","GR2M","GR1A","CemaNeige"))>0){
        FUN_TRANSFO <- FUN1; 
      } else {
        FUN_TRANSFO <- function(ParamIn,Direction){
          Bool <- is.matrix(ParamIn);
          if(Bool==FALSE){ 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==FALSE){ ParamOut <- ParamOut[1,]; }
          return(ParamOut);
        }
      }
    }
    if(is.null(FUN_TRANSFO)){ stop("FUN_TRANSFO was not found \n"); 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; }