Commit f7323d49 authored by Delaigue Olivier's avatar Delaigue Olivier
Browse files

v1.0.13.9 minor syntax revisions in Calibration_Michel

parent 1f275390
Package: airGR Package: airGR
Type: Package Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.0.13.8 Version: 1.0.13.9
Date: 2018-08-30 Date: 2018-08-31
Authors@R: c( Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")), person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
person("Charles", "Perrin", role = c("aut", "ths"), comment = c(ORCID = "0000-0001-8552-1881")), person("Charles", "Perrin", role = c("aut", "ths"), comment = c(ORCID = "0000-0001-8552-1881")),
......
...@@ -14,7 +14,7 @@ output: ...@@ -14,7 +14,7 @@ output:
### 1.0.13.8 Release Notes (2018-08-30) ### 1.0.13.8 Release Notes (2018-08-31)
#### Deprectated and defunct #### Deprectated and defunct
......
Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions, FUN_MOD, FUN_CRIT, FUN_TRANSFO = NULL, verbose = TRUE) { Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions,
FUN_MOD, FUN_CRIT, FUN_TRANSFO = NULL, verbose = TRUE) {
##_____Arguments_check_____________________________________________________________________ ##_____Arguments_check_____________________________________________________________________
if (!inherits(InputsModel, "InputsModel")) { if (!inherits(InputsModel, "InputsModel")) {
stop("InputsModel must be of class 'InputsModel' \n") stop("InputsModel must be of class 'InputsModel' \n")
return(NULL) return(NULL)
...@@ -65,7 +66,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -65,7 +66,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
if (Bool == FALSE) { if (Bool == FALSE) {
ParamIn <- rbind(ParamIn) ParamIn <- rbind(ParamIn)
} }
ParamOut <- NA*ParamIn ParamOut <- NA * ParamIn
NParam <- ncol(ParamIn) NParam <- ncol(ParamIn)
ParamOut[, 1:(NParam-2)] <- FUN1(ParamIn[, 1:(NParam-2)], Direction) ParamOut[, 1:(NParam-2)] <- FUN1(ParamIn[, 1:(NParam-2)], Direction)
ParamOut[, (NParam-1):NParam ] <- FUN2(ParamIn[, (NParam-1):NParam ], Direction) ParamOut[, (NParam-1):NParam ] <- FUN2(ParamIn[, (NParam-1):NParam ], Direction)
...@@ -102,19 +103,19 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -102,19 +103,19 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
stop("Calibration_Michel can handle a maximum of 20 parameters \n") stop("Calibration_Michel can handle a maximum of 20 parameters \n")
return(NULL) return(NULL)
} }
HistParamR <- matrix(NA, nrow = 500*NParam, ncol = NParam) HistParamR <- matrix(NA, nrow = 500 * NParam, ncol = NParam)
HistParamT <- matrix(NA, nrow = 500*NParam, ncol = NParam) HistParamT <- matrix(NA, nrow = 500 * NParam, ncol = NParam)
HistCrit <- matrix(NA, nrow = 500*NParam, ncol = 1) HistCrit <- matrix(NA, nrow = 500 * NParam, ncol = 1)
CritName <- NULL CritName <- NULL
CritBestValue <- NULL CritBestValue <- NULL
Multiplier <- NULL Multiplier <- NULL
CritOptim <- +1E100 CritOptim <- +1e100
##_temporary_change_of_Outputs_Sim ##_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 RunOptions$Outputs_Sim <- RunOptions$Outputs_Cal ### this reduces the size of the matrix exchange with fortran and therefore speeds the calibration
##_____Parameter_Grid_Screening____________________________________________________________ ##_____Parameter_Grid_Screening____________________________________________________________
##Definition_of_the_function_creating_all_possible_parameter_sets_from_different_values_for_each_parameter ##Definition_of_the_function_creating_all_possible_parameter_sets_from_different_values_for_each_parameter
...@@ -132,16 +133,18 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -132,16 +133,18 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
} }
if (PrefilteringType == 2) { if (PrefilteringType == 2) {
DistribParamR <- CalibOptions$StartParamDistrib DistribParamR <- CalibOptions$StartParamDistrib
DistribParamR[,!OptimParam] <- NA DistribParamR[, !OptimParam] <- NA
CandidatesParamR <- ProposeCandidatesGrid(DistribParamR)$NewCandidates CandidatesParamR <- ProposeCandidatesGrid(DistribParamR)$NewCandidates
} }
##Remplacement_of_non_optimised_values_____________________________________ ##Remplacement_of_non_optimised_values_____________________________________
CandidatesParamR <- apply(CandidatesParamR, 1, function(x) { CandidatesParamR <- apply(CandidatesParamR, 1, function(x) {
x[!OptimParam] <- CalibOptions$FixedParam[!OptimParam] x[!OptimParam] <- CalibOptions$FixedParam[!OptimParam]
return(x)}) return(x)
if (NParam>1) { })
if (NParam > 1) {
CandidatesParamR <- t(CandidatesParamR) CandidatesParamR <- t(CandidatesParamR)
} else { CandidatesParamR <- cbind(CandidatesParamR) } else {
CandidatesParamR <- cbind(CandidatesParamR)
} }
##Loop_to_test_the_various_candidates______________________________________ ##Loop_to_test_the_various_candidates______________________________________
...@@ -159,8 +162,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -159,8 +162,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
for (iNew in 1:nrow(CandidatesParamR)) { for (iNew in 1:nrow(CandidatesParamR)) {
if (verbose & Ncandidates > 1) { if (verbose & Ncandidates > 1) {
for (k in c(2, 4, 6, 8)) { for (k in c(2, 4, 6, 8)) {
if (iNew == round(k/10*Ncandidates)) { if (iNew == round(k / 10 * Ncandidates)) {
message(" ", 10*k, "%", appendLF = FALSE) message(" ", 10 * k, "%", appendLF = FALSE)
} }
} }
} }
...@@ -170,8 +173,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -170,8 +173,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Calibration_criterion_computation ##Calibration_criterion_computation
OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE) OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE)
if (!is.na(OutputsCrit$CritValue)) { if (!is.na(OutputsCrit$CritValue)) {
if (OutputsCrit$CritValue*OutputsCrit$Multiplier < CritOptim) { if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue*OutputsCrit$Multiplier CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier
iNewOptim <- iNew iNewOptim <- iNew
} }
} }
...@@ -203,7 +206,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -203,7 +206,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
message("\t Starting point for steepest-descent local search:") message("\t Starting point for steepest-descent local search:")
} }
message("\t Param = ", paste(sprintf("%8.3f", ParamStartR), collapse = " , ")) message("\t Param = ", paste(sprintf("%8.3f", ParamStartR), collapse = " , "))
message(sprintf("\t Crit %-12s = %.4f", CritName, CritStart*Multiplier)) message(sprintf("\t Crit %-12s = %.4f", CritName, CritStart * Multiplier))
} }
##Results_archiving________________________________________________________ ##Results_archiving________________________________________________________
HistParamR[1, ] <- ParamStartR HistParamR[1, ] <- ParamStartR
...@@ -213,7 +216,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -213,7 +216,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##_____Steepest_Descent_Local_Search_______________________________________________________ ##_____Steepest_Descent_Local_Search_______________________________________________________
##Definition_of_the_function_creating_new_parameter_sets_through_a_step_by_step_progression_procedure ##Definition_of_the_function_creating_new_parameter_sets_through_a_step_by_step_progression_procedure
...@@ -227,7 +230,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -227,7 +230,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
stop("each input set must have the same number of values \n") stop("each input set must have the same number of values \n")
return(NULL) return(NULL)
} }
##Proposal_of_new_parameter_sets ###(local search providing 2*NParam-1 new sets) ##Proposal_of_new_parameter_sets ###(local search providing 2 * NParam-1 new sets)
NParam <- ncol(NewParamOptimT) NParam <- ncol(NewParamOptimT)
VECT <- NULL VECT <- NULL
for (I in 1:NParam) { for (I in 1:NParam) {
...@@ -258,7 +261,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -258,7 +261,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
Add <- FALSE Add <- FALSE
} }
##We_add_the_candidate_to_our_list ##We_add_the_candidate_to_our_list
if (Add == TRUE) { if (Add) {
VECT <- c(VECT, PotentialCandidateT) VECT <- c(VECT, PotentialCandidateT)
} }
} }
...@@ -276,7 +279,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -276,7 +279,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
} }
Pace <- 0.64 Pace <- 0.64
PaceDiag <- rep(0, NParam) PaceDiag <- rep(0, NParam)
CLG <- 0.7^(1/NParam) CLG <- 0.7^(1 / NParam)
Compt <- 0 Compt <- 0
CritOptim <- CritStart CritOptim <- CritStart
##Conversion_of_real_parameter_values ##Conversion_of_real_parameter_values
...@@ -287,7 +290,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -287,7 +290,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##START_LOOP_ITER_________________________________________________________ ##START_LOOP_ITER_________________________________________________________
for (ITER in 1:(100*NParam)) { for (ITER in 1:(100 * NParam)) {
##Exit_loop_when_Pace_becomes_too_small___________________________________ ##Exit_loop_when_Pace_becomes_too_small___________________________________
...@@ -302,7 +305,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -302,7 +305,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Remplacement_of_non_optimised_values_____________________________________ ##Remplacement_of_non_optimised_values_____________________________________
CandidatesParamR <- apply(CandidatesParamR, 1, function(x) { CandidatesParamR <- apply(CandidatesParamR, 1, function(x) {
x[!OptimParam] <- CalibOptions$FixedParam[!OptimParam] x[!OptimParam] <- CalibOptions$FixedParam[!OptimParam]
return(x)}) return(x)
})
if (NParam > 1) { if (NParam > 1) {
CandidatesParamR <- t(CandidatesParamR) CandidatesParamR <- t(CandidatesParamR)
} else { } else {
...@@ -319,8 +323,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -319,8 +323,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Calibration_criterion_computation ##Calibration_criterion_computation
OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE) OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE)
if (!is.na(OutputsCrit$CritValue)) { if (!is.na(OutputsCrit$CritValue)) {
if (OutputsCrit$CritValue*OutputsCrit$Multiplier < CritOptim) { if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue*OutputsCrit$Multiplier CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier
iNewOptim <- iNew iNewOptim <- iNew
} }
} }
...@@ -333,9 +337,9 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -333,9 +337,9 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##We_store_the_optimal_set ##We_store_the_optimal_set
OldParamOptimT <- NewParamOptimT OldParamOptimT <- NewParamOptimT
NewParamOptimT <- matrix(CandidatesParamT[iNewOptim, 1:NParam], nrow = 1) NewParamOptimT <- matrix(CandidatesParamT[iNewOptim, 1:NParam], nrow = 1)
Compt <- Compt+1 Compt <- Compt + 1
##When_necessary_we_increase_the_pace ### if_successive_progress_occur_in_a_row ##When_necessary_we_increase_the_pace ### if_successive_progress_occur_in_a_row
if (Compt > 2*NParam) { if (Compt > 2 * NParam) {
Pace <- Pace * 2 Pace <- Pace * 2
Compt <- 0 Compt <- 0
} }
...@@ -354,7 +358,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -354,7 +358,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Test_of_an_additional_candidate_using_diagonal_progress_________________ ##Test_of_an_additional_candidate_using_diagonal_progress_________________
if (ITER > 4*NParam) { if (ITER > 4 * NParam) {
NRuns <- NRuns + 1 NRuns <- NRuns + 1
iNewOptim <- 0 iNewOptim <- 0
iNew <- 1 iNew <- 1
...@@ -379,8 +383,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -379,8 +383,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
OutputsModel <- FUN_MOD(InputsModel, RunOptions, Param) OutputsModel <- FUN_MOD(InputsModel, RunOptions, Param)
##Calibration_criterion_computation ##Calibration_criterion_computation
OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE) OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE)
if (OutputsCrit$CritValue*OutputsCrit$Multiplier < CritOptim) { if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue*OutputsCrit$Multiplier CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier
iNewOptim <- iNew iNewOptim <- iNew
} }
##When_a_progress_has_been_achieved ##When_a_progress_has_been_achieved
...@@ -402,7 +406,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -402,7 +406,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
} ##END_LOOP_ITER_________________________________________________________ } ##END_LOOP_ITER_________________________________________________________
ITER <- ITER-1 ITER <- ITER - 1
##Case_when_the_starting_parameter_set_remains_the_best_solution__________ ##Case_when_the_starting_parameter_set_remains_the_best_solution__________
...@@ -418,7 +422,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -418,7 +422,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
if (verbose) { if (verbose) {
message(sprintf("\t Calibration completed (%s iterations, %s runs)", NIter, NRuns)) message(sprintf("\t Calibration completed (%s iterations, %s runs)", NIter, NRuns))
message("\t Param = ", paste(sprintf("%8.3f", ParamFinalR), collapse = " , ")) message("\t Param = ", paste(sprintf("%8.3f", ParamFinalR), collapse = " , "))
message(sprintf("\t Crit %-12s = %.4f", CritName, CritFinal*Multiplier)) message(sprintf("\t Crit %-12s = %.4f", CritName, CritFinal * Multiplier))
} }
##Results_archiving_______________________________________________________ ##Results_archiving_______________________________________________________
HistParamR <- cbind(HistParamR[1:NIter, ]) HistParamR <- cbind(HistParamR[1:NIter, ])
...@@ -434,10 +438,11 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions ...@@ -434,10 +438,11 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
colnames(MatBoolCrit) <- c("BoolCrit_Requested", "BoolCrit_Actual") colnames(MatBoolCrit) <- c("BoolCrit_Requested", "BoolCrit_Actual")
##_____Output______________________________________________________________________________ ##_____Output______________________________________________________________________________
OutputsCalib <- list(ParamFinalR = as.double(ParamFinalR), CritFinal = CritFinal*Multiplier, OutputsCalib <- list(ParamFinalR = as.double(ParamFinalR), CritFinal = CritFinal * Multiplier,
NIter = NIter, NRuns = NRuns, NIter = NIter, NRuns = NRuns,
HistParamR = HistParamR, HistCrit = HistCrit*Multiplier, MatBoolCrit = MatBoolCrit, HistParamR = HistParamR, HistCrit = HistCrit * Multiplier,
MatBoolCrit = MatBoolCrit,
CritName = CritName, CritBestValue = CritBestValue) CritName = CritName, CritBestValue = CritBestValue)
class(OutputsCalib) <- c("OutputsCalib", "HBAN") class(OutputsCalib) <- c("OutputsCalib", "HBAN")
return(OutputsCalib) return(OutputsCalib)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment