This project manages its dependencies using Composer. Learn more
Calibration_Michel.R 16.19 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)
  # Handling 'FUN_TRANSFO' from direct argument or provided by 'CaliOptions'
  if (!is.null(FUN_TRANSFO)) {
    FUN_TRANSFO <- match.fun(FUN_TRANSFO)
  } else if(!is.null(CalibOptions$FUN_TRANSFO)) {
    FUN_TRANSFO <- CalibOptions$FUN_TRANSFO
  } else {
    stop("'FUN_TRANSFO' is not provided neither as 'FUN_TRANSFO' argument or in 'CaliOptions' argument")
  ##_____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")
  ##_variables_initialisation
  ParamFinalR <- NULL
  ParamFinalT <- NULL
  CritFinal   <- NULL
  NRuns <- 0
  NIter <- 0
  if ("StartParamDistrib" %in% names(CalibOptions)) {
    PrefilteringType <- 2
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
} else { PrefilteringType <- 1 } if (PrefilteringType == 1) { NParam <- ncol(CalibOptions$StartParamList) } if (PrefilteringType == 2) { NParam <- ncol(CalibOptions$StartParamDistrib) } if (NParam > 20) { stop("Calibration_Michel can handle a maximum of 20 parameters") } HistParamR <- matrix(NA, nrow = 500 * NParam, ncol = NParam) HistParamT <- matrix(NA, nrow = 500 * NParam, ncol = NParam) HistCrit <- matrix(NA, nrow = 500 * NParam, ncol = 1) CritName <- NULL CritBestValue <- NULL Multiplier <- NULL CritOptim <- +1e100 ##_temporary_change_of_Outputs_Sim RunOptions$Outputs_Sim <- RunOptions$Outputs_Cal ### this reduces the size of the matrix exchange with fortran and therefore speeds the calibration ##_____Parameter_Grid_Screening____________________________________________________________ ##Definition_of_the_function_creating_all_possible_parameter_sets_from_different_values_for_each_parameter ProposeCandidatesGrid <- function(DistribParam) { NewCandidates <- expand.grid(lapply(seq_len(ncol(DistribParamR)), function(x) DistribParam[, x])) NewCandidates <- unique(NewCandidates) # to avoid duplicates when a parameter is set Output <- list(NewCandidates = NewCandidates) } ##Creation_of_new_candidates_______________________________________________ OptimParam <- is.na(CalibOptions$FixedParam) if (PrefilteringType == 1) { CandidatesParamR <- CalibOptions$StartParamList } if (PrefilteringType == 2) { DistribParamR <- CalibOptions$StartParamDistrib DistribParamR[, !OptimParam] <- NA CandidatesParamR <- ProposeCandidatesGrid(DistribParamR)$NewCandidates } ##Remplacement_of_non_optimised_values_____________________________________ CandidatesParamR <- apply(CandidatesParamR, 1, function(x) { x[!OptimParam] <- CalibOptions$FixedParam[!OptimParam] return(x) }) if (NParam > 1) { CandidatesParamR <- t(CandidatesParamR) } else { CandidatesParamR <- cbind(CandidatesParamR) } ##Loop_to_test_the_various_candidates______________________________________ iNewOptim <- 0 Ncandidates <- nrow(CandidatesParamR) if (verbose & Ncandidates > 1) { if (PrefilteringType == 1) { message("List-Screening in progress (", appendLF = FALSE) } if (PrefilteringType == 2) { message("Grid-Screening in progress (", appendLF = FALSE) } message("0%", appendLF = FALSE) } for (iNew in 1:nrow(CandidatesParamR)) { if (verbose & Ncandidates > 1) {
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
for (k in c(2, 4, 6, 8)) { if (iNew == round(k / 10 * Ncandidates)) { message(" ", 10 * k, "%", appendLF = FALSE) } } } ##Model_run Param <- CandidatesParamR[iNew, ] OutputsModel <- RunModel(InputsModel, RunOptions, Param, FUN_MOD = FUN_MOD, ...) ##Calibration_criterion_computation OutputsCrit <- ErrorCrit(InputsCrit, OutputsModel, verbose = FALSE) if (!is.na(OutputsCrit$CritValue)) { if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) { CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier iNewOptim <- iNew } } ##Storage_of_crit_info if (is.null(CritName) | is.null(CritBestValue) | is.null(Multiplier)) { CritName <- OutputsCrit$CritName CritBestValue <- OutputsCrit$CritBestValue Multiplier <- OutputsCrit$Multiplier } } if (verbose & Ncandidates > 1) { message(" 100%)\n", appendLF = FALSE) } ##End_of_first_step_Parameter_Screening____________________________________ ParamStartR <- CandidatesParamR[iNewOptim, ] if (!is.matrix(ParamStartR)) { ParamStartR <- matrix(ParamStartR, nrow = 1) } ParamStartT <- FUN_TRANSFO(ParamStartR, "RT") CritStart <- CritOptim NRuns <- NRuns + nrow(CandidatesParamR) if (verbose) { if (Ncandidates > 1) { message(sprintf("\t Screening completed (%s runs)", NRuns)) } if (Ncandidates == 1) { message("\t Starting point for steepest-descent local search:") } message("\t Param = ", paste(sprintf("%8.3f", ParamStartR), collapse = ", ")) message(sprintf("\t Crit. %-12s = %.4f", CritName, CritStart * Multiplier)) } ##Results_archiving________________________________________________________ HistParamR[1, ] <- ParamStartR HistParamT[1, ] <- ParamStartT HistCrit[1, ] <- CritStart ##_____Steepest_Descent_Local_Search_______________________________________________________ ##Definition_of_the_function_creating_new_parameter_sets_through_a_step_by_step_progression_procedure ProposeCandidatesLoc <- function(NewParamOptimT, OldParamOptimT, RangesT, OptimParam, Pace) { ##Format_checking if (nrow(NewParamOptimT) != 1 | nrow(OldParamOptimT) != 1) { stop("each input set must be a matrix of one single line") } if (ncol(NewParamOptimT)!=ncol(OldParamOptimT) | ncol(NewParamOptimT) != length(OptimParam)) { stop("each input set must have the same number of values") } ##Proposal_of_new_parameter_sets ###(local search providing 2 * NParam-1 new sets) NParam <- ncol(NewParamOptimT)