Failed to fetch fork details. Try again later.
-
Delaigue Olivier authoredddf30bac
Forked from
HYCAR-Hydro / airGR
Source project has a limited visibility.
#*************************************************************************************************#' Creation of the CalibOptions object required to the Calibration functions.#'#' Users wanting to use FUN_MOD, FUN_CALIB or FUN_TRANSFO functions that are not included in #' the package must create their own CalibOptions object accordingly.#*************************************************************************************************#' @title Creation of the CalibOptions object required to the Calibration functions#' @author Laurent Coron (June 2014)#' @seealso \code{\link{Calibration}}, \code{\link{RunModel}}#' @example tests/example_Calibration.R#' @encoding UTF-8#' @export#_FunctionInputs__________________________________________________________________________________#' @param FUN_MOD [function] hydrological model function (e.g. RunModel_GR4J, RunModel_CemaNeigeGR4J)#' @param FUN_CALIB (optional) [function] calibration algorithm function (e.g. Calibration_HBAN, Calibration_optim), default=Calibration_HBAN#' @param FUN_TRANSFO (optional) [function] model parameters transformation function, if the FUN_MOD used is native in the package FUN_TRANSFO is automatically defined#' @param OptimParam (optional) [boolean] vector of booleans indicating which parameters must be optimised (NParam columns, 1 line) #' @param FixedParam (optional) [numeric] vector giving the values to allocate to non-optimised parameter values (NParam columns, 1 line)#' @param SearchRanges (optional) [numeric] matrix giving the ranges of real parameters (NParam columns, 2 lines)#' \tabular{llllll}{#' \tab [X1] \tab [X2] \tab [X3] \tab [...] \tab [Xi] \cr#' [1,] \tab 0 \tab -1 \tab 0 \tab ... \tab 0.0 \cr#' [2,] \tab 3000 \tab +1 \tab 100 \tab ... \tab 3.0 \cr#' }#' @param StartParam (optional) [numeric] vector of parameter values used to start global search calibration procedure (this argument is used by Calibration_optim but not by Calibration_HBAN)#' \tabular{llllll}{#' \tab [X1] \tab [X2] \tab [X3] \tab [...] \tab [Xi] \cr#' \tab 1000 \tab -0.5 \tab 22 \tab ... \tab 1.1 \cr#' }#' @param StartParamList (optional) [numeric] matrix of parameter sets used for grid-screening calibration procedure (values in columns, sets in line) (this argument is used by Calibration_HBAN but not by Calibration_optim)#' \tabular{llllll}{#' \tab [X1] \tab [X2] \tab [X3] \tab [...] \tab [Xi] \cr#' [set1] \tab 800 \tab -0.7 \tab 25 \tab ... \tab 1.0 \cr#' [set2] \tab 1000 \tab -0.5 \tab 22 \tab ... \tab 1.1 \cr#' [...] \tab ... \tab ... \tab ... \tab ... \tab ... \cr#' [set n] \tab 200 \tab -0.3 \tab 17 \tab ... \tab 1.0 \cr#' }#' @param StartParamDistrib (optional) [numeric] matrix of parameter values used for grid-screening calibration procedure (values in columns, percentiles in line) \cr#' \tabular{llllll}{#' \tab [X1] \tab [X2] \tab [X3] \tab [...] \tab [Xi] \cr#' [value1] \tab 800 \tab -0.7 \tab 25 \tab ... \tab 1.0 \cr#' [value2] \tab 1000 \tab NA \tab 50 \tab ... \tab 1.2 \cr#' [value3] \tab 1200 \tab NA \tab NA \tab ... \tab 1.6 \cr#' }#_FunctionOutputs_________________________________________________________________________________#' @return [list] object of class \emph{CalibOptions} containing the data required to evaluate the model outputs; it can include the following:#' \tabular{ll}{#' \emph{$OptimParam } \tab [boolean] vector of booleans indicating which parameters must be optimised \cr#' \emph{$FixedParam } \tab [numeric] vector giving the values to allocate to non-optimised parameter values \cr#' \emph{$SearchRanges } \tab [numeric] matrix giving the ranges of real parameters \cr#' \emph{$StartParam } \tab [numeric] vector of parameter values used to start global search calibration procedure \cr#' \emph{$StartParamList } \tab [numeric] matrix of parameter sets used for grid-screening calibration procedure \cr#' \emph{$StartParamDistrib} \tab [numeric] matrix of parameter values used for grid-screening calibration procedure \cr#' }#**************************************************************************************************CreateCalibOptions <- function(FUN_MOD,FUN_CALIB=Calibration_HBAN,FUN_TRANSFO=NULL,OptimParam=NULL,FixedParam=NULL,SearchRanges=NULL, StartParam=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; }7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
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_HBAN )){ ObjectClass <- c(ObjectClass,"HBAN" ); BOOL <- TRUE; }
if(identical(FUN_CALIB,Calibration_optim )){ ObjectClass <- c(ObjectClass,"optim" ); 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; }
##check_OptimParam
if(is.null(OptimParam)){
OptimParam <- rep(TRUE,NParam);
} else {
if(!is.vector(OptimParam) ){ stop("OptimParam must be a vector of booleans \n"); return(NULL); }
if(length(OptimParam)!=NParam){ stop("Incompatibility between OptimParam length and FUN_MOD \n"); return(NULL); }
if(!is.logical(OptimParam) ){ stop("OptimParam must be a vector of booleans \n"); return(NULL); }
}
##check_FixedParam
if(is.null(FixedParam)){
FixedParam <- rep(NA,NParam);
} else {
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
if(!is.vector(FixedParam) ){ stop("FixedParam must be a vector \n"); return(NULL); }
if(length(FixedParam)!=NParam ){ stop("Incompatibility between OptimParam length and FUN_MOD \n"); return(NULL); }
if(sum(!OptimParam)>0){
if(!is.numeric(FixedParam[!OptimParam])){ stop("if OptimParam[i]==FALSE, FixedParam[i] must be a numeric value \n"); return(NULL); } }
}
##check_SearchRanges
if(is.null(SearchRanges)){
ParamT <- matrix(c(rep(-9.99,NParam),rep(+9.99,NParam)),ncol=NParam,byrow=TRUE);
SearchRanges <- TransfoParam(ParamIn=ParamT,Direction="TR",FUN_TRANSFO=FUN_TRANSFO);
} else {
if(!is.matrix( SearchRanges) ){ stop("SearchRanges must be a matrix \n"); return(NULL); }
if(!is.numeric(SearchRanges) ){ stop("SearchRanges must be a matrix of numeric values \n"); return(NULL); }
if(sum(is.na(SearchRanges))!=0){ stop("SearchRanges must not include NA values \n"); return(NULL); }
if(nrow(SearchRanges)!=2 ){ stop("SearchRanges must have 2 rows \n"); return(NULL); }
if(ncol(SearchRanges)!=NParam ){ stop("Incompatibility between SearchRanges ncol and FUN_MOD \n"); return(NULL); }
}
##check_StartParamList_and_StartParamDistrib__default_values
if( ("HBAN" %in% ObjectClass & is.null(StartParamList) & is.null(StartParamDistrib)) |
("optim" %in% ObjectClass & is.null(StartParam)) ){
if("GR4H"%in% ObjectClass){
ParamT <- matrix( c( +5.12, -1.18, +4.34, -9.69,
+5.58, -0.85, +4.74, -9.47,
+6.01, -0.50, +5.14, -8.87),ncol=NParam,byrow=TRUE); }
if("GR4J"%in% ObjectClass){
ParamT <- matrix( c( +5.13, -1.60, +3.03, -9.05,
+5.51, -0.61, +3.74, -8.51,
+6.07, -0.02, +4.42, -8.06),ncol=NParam,byrow=TRUE); }
if("GR5J"%in% ObjectClass){
ParamT <- matrix( c( +5.17, -1.13, +3.08, -9.37, -7.45,
+5.55, -0.46, +3.75, -9.09, -4.69,
+6.10, -0.11, +4.43, -8.60, -0.66),ncol=NParam,byrow=TRUE); }
if("GR6J"%in% ObjectClass){
ParamT <- matrix( c( +4.41, +0.41, +2.88, -9.10, -0.13, +0.81,
+5.02, +0.61, +3.45, -8.68, +1.95, +2.27,
+5.58, +0.78, +4.18, -8.12, +3.59, +3.56),ncol=NParam,byrow=TRUE); }
if("GR2M"%in% ObjectClass){
ParamT <- matrix( c( +5.03, -7.15,
+5.22, -6.74,
+5.85, -6.37),ncol=NParam,byrow=TRUE); }
if("GR1A"%in% ObjectClass){
ParamT <- matrix( c( -1.69,
-0.38,
+1.39),ncol=NParam,byrow=TRUE); }
if("CemaNeige"%in% ObjectClass){
ParamT <- matrix( c( -9.96, +6.63,
-9.14, +6.90,
+4.10, +7.21),ncol=NParam,byrow=TRUE); }
if("CemaNeigeGR4J"%in% ObjectClass){
ParamT <- matrix( c( +5.13, -1.60, +3.03, -9.05, -9.96, +6.63,
+5.51, -0.61, +3.74, -8.51, -9.14, +6.90,
+6.07, -0.02, +4.42, -8.06, +4.10, +7.21),ncol=NParam,byrow=TRUE); }
if("CemaNeigeGR5J"%in% ObjectClass){
ParamT <- matrix( c( +5.17, -1.13, +3.08, -9.37, -7.45, -9.96, +6.63,
+5.55, -0.46, +3.75, -9.09, -4.69, -9.14, +6.90,
+6.10, -0.11, +4.43, -8.60, -0.66, +4.10, +7.21),ncol=NParam,byrow=TRUE); }
if("CemaNeigeGR6J"%in% ObjectClass){
ParamT <- matrix( c( +4.41, +0.41, +2.88, -9.10, -0.13, +0.81, -9.96, +6.63,
+5.02, +0.61, +3.45, -8.68, +1.95, +2.27, -9.14, +6.90,
+5.58, +0.78, +4.18, -8.12, +3.59, +3.56, +4.10, +7.21),ncol=NParam,byrow=TRUE); }
StartParamList <- NULL;
StartParamDistrib <- TransfoParam(ParamIn=ParamT,Direction="TR",FUN_TRANSFO=FUN_TRANSFO);
StartParam <- StartParamDistrib[2,];
}
##check_StartParamList_and_StartParamDistrib__format
if("HBAN" %in% ObjectClass & !is.null(StartParamList)){
211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243
if(!is.matrix( StartParamList) ){ stop("StartParamList must be a matrix \n"); return(NULL); }
if(!is.numeric(StartParamList) ){ stop("StartParamList must be a matrix of numeric values \n"); return(NULL); }
if(sum(is.na(StartParamList))!=0){ stop("StartParamList must not include NA values \n"); return(NULL); }
if(ncol(StartParamList)!=NParam ){ stop("Incompatibility between StartParamList ncol and FUN_MOD \n"); return(NULL); }
}
if("HBAN" %in% ObjectClass & !is.null(StartParamDistrib)){
if(!is.matrix( StartParamDistrib) ){ stop("StartParamDistrib must be a matrix \n"); return(NULL); }
if(!is.numeric(StartParamDistrib[1,]) ){ stop("StartParamDistrib must be a matrix of numeric values \n"); return(NULL); }
if(sum(is.na(StartParamDistrib[1,]))!=0){ stop("StartParamDistrib must not include NA values on the first line \n"); return(NULL); }
if(ncol(StartParamDistrib)!=NParam ){ stop("Incompatibility between StartParamDistrib ncol and FUN_MOD \n"); return(NULL); }
}
if("optim" %in% ObjectClass & !is.null(StartParam)){
if(!is.vector( StartParam) ){ stop("StartParam must be a vector \n"); return(NULL); }
if(!is.numeric(StartParam) ){ stop("StartParam must be a vector of numeric values \n"); return(NULL); }
if(sum(is.na(StartParam))!=0 ){ stop("StartParam must not include NA values \n"); return(NULL); }
if(length(StartParam)!=NParam ){ stop("Incompatibility between StartParam length and FUN_MOD \n"); return(NULL); }
}
##Create_CalibOptions
CalibOptions <- list(OptimParam=OptimParam,FixedParam=FixedParam,SearchRanges=SearchRanges);
if(!is.null(StartParam )){ CalibOptions <- c(CalibOptions,list(StartParam=StartParam)); }
if(!is.null(StartParamList )){ CalibOptions <- c(CalibOptions,list(StartParamList=StartParamList)); }
if(!is.null(StartParamDistrib)){ CalibOptions <- c(CalibOptions,list(StartParamDistrib=StartParamDistrib)); }
class(CalibOptions) <- c("CalibOptions",ObjectClass);
return(CalibOptions);
}