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
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.0.13.8
Date: 2018-08-30
Version: 1.0.13.9
Date: 2018-08-31
Authors@R: c(
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")),
......
......@@ -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
......
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")) {
stop("InputsModel must be of class 'InputsModel' \n")
return(NULL)
......@@ -65,7 +66,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
if (Bool == FALSE) {
ParamIn <- rbind(ParamIn)
}
ParamOut <- NA*ParamIn
ParamOut <- NA * ParamIn
NParam <- ncol(ParamIn)
ParamOut[, 1:(NParam-2)] <- FUN1(ParamIn[, 1:(NParam-2)], Direction)
ParamOut[, (NParam-1):NParam ] <- FUN2(ParamIn[, (NParam-1):NParam ], Direction)
......@@ -102,19 +103,19 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
stop("Calibration_Michel can handle a maximum of 20 parameters \n")
return(NULL)
}
HistParamR <- matrix(NA, nrow = 500*NParam, ncol = NParam)
HistParamT <- matrix(NA, nrow = 500*NParam, ncol = NParam)
HistCrit <- matrix(NA, nrow = 500*NParam, ncol = 1)
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
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____________________________________________________________
##_____Parameter_Grid_Screening____________________________________________________________
##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
}
if (PrefilteringType == 2) {
DistribParamR <- CalibOptions$StartParamDistrib
DistribParamR[,!OptimParam] <- NA
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) {
return(x)
})
if (NParam > 1) {
CandidatesParamR <- t(CandidatesParamR)
} else { CandidatesParamR <- cbind(CandidatesParamR)
} else {
CandidatesParamR <- cbind(CandidatesParamR)
}
##Loop_to_test_the_various_candidates______________________________________
......@@ -159,8 +162,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
for (iNew in 1:nrow(CandidatesParamR)) {
if (verbose & Ncandidates > 1) {
for (k in c(2, 4, 6, 8)) {
if (iNew == round(k/10*Ncandidates)) {
message(" ", 10*k, "%", appendLF = FALSE)
if (iNew == round(k / 10 * Ncandidates)) {
message(" ", 10 * k, "%", appendLF = FALSE)
}
}
}
......@@ -170,8 +173,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Calibration_criterion_computation
OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE)
if (!is.na(OutputsCrit$CritValue)) {
if (OutputsCrit$CritValue*OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue*OutputsCrit$Multiplier
if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier
iNewOptim <- iNew
}
}
......@@ -203,7 +206,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
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))
message(sprintf("\t Crit %-12s = %.4f", CritName, CritStart * Multiplier))
}
##Results_archiving________________________________________________________
HistParamR[1, ] <- ParamStartR
......@@ -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
......@@ -227,7 +230,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
stop("each input set must have the same number of values \n")
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)
VECT <- NULL
for (I in 1:NParam) {
......@@ -258,7 +261,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
Add <- FALSE
}
##We_add_the_candidate_to_our_list
if (Add == TRUE) {
if (Add) {
VECT <- c(VECT, PotentialCandidateT)
}
}
......@@ -276,7 +279,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
}
Pace <- 0.64
PaceDiag <- rep(0, NParam)
CLG <- 0.7^(1/NParam)
CLG <- 0.7^(1 / NParam)
Compt <- 0
CritOptim <- CritStart
##Conversion_of_real_parameter_values
......@@ -287,7 +290,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##START_LOOP_ITER_________________________________________________________
for (ITER in 1:(100*NParam)) {
for (ITER in 1:(100 * NParam)) {
##Exit_loop_when_Pace_becomes_too_small___________________________________
......@@ -302,7 +305,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Remplacement_of_non_optimised_values_____________________________________
CandidatesParamR <- apply(CandidatesParamR, 1, function(x) {
x[!OptimParam] <- CalibOptions$FixedParam[!OptimParam]
return(x)})
return(x)
})
if (NParam > 1) {
CandidatesParamR <- t(CandidatesParamR)
} else {
......@@ -319,8 +323,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Calibration_criterion_computation
OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE)
if (!is.na(OutputsCrit$CritValue)) {
if (OutputsCrit$CritValue*OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue*OutputsCrit$Multiplier
if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier
iNewOptim <- iNew
}
}
......@@ -333,9 +337,9 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##We_store_the_optimal_set
OldParamOptimT <- NewParamOptimT
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
if (Compt > 2*NParam) {
if (Compt > 2 * NParam) {
Pace <- Pace * 2
Compt <- 0
}
......@@ -354,7 +358,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
##Test_of_an_additional_candidate_using_diagonal_progress_________________
if (ITER > 4*NParam) {
if (ITER > 4 * NParam) {
NRuns <- NRuns + 1
iNewOptim <- 0
iNew <- 1
......@@ -379,8 +383,8 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
OutputsModel <- FUN_MOD(InputsModel, RunOptions, Param)
##Calibration_criterion_computation
OutputsCrit <- FUN_CRIT(InputsCrit, OutputsModel, verbose = FALSE)
if (OutputsCrit$CritValue*OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue*OutputsCrit$Multiplier
if (OutputsCrit$CritValue * OutputsCrit$Multiplier < CritOptim) {
CritOptim <- OutputsCrit$CritValue * OutputsCrit$Multiplier
iNewOptim <- iNew
}
##When_a_progress_has_been_achieved
......@@ -402,7 +406,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
} ##END_LOOP_ITER_________________________________________________________
ITER <- ITER-1
ITER <- ITER - 1
##Case_when_the_starting_parameter_set_remains_the_best_solution__________
......@@ -418,7 +422,7 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
if (verbose) {
message(sprintf("\t Calibration completed (%s iterations, %s runs)", NIter, NRuns))
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_______________________________________________________
HistParamR <- cbind(HistParamR[1:NIter, ])
......@@ -434,10 +438,11 @@ Calibration_Michel <- function(InputsModel, RunOptions, InputsCrit, CalibOptions
colnames(MatBoolCrit) <- c("BoolCrit_Requested", "BoolCrit_Actual")
##_____Output______________________________________________________________________________
OutputsCalib <- list(ParamFinalR = as.double(ParamFinalR), CritFinal = CritFinal*Multiplier,
##_____Output______________________________________________________________________________
OutputsCalib <- list(ParamFinalR = as.double(ParamFinalR), CritFinal = CritFinal * Multiplier,
NIter = NIter, NRuns = NRuns,
HistParamR = HistParamR, HistCrit = HistCrit*Multiplier, MatBoolCrit = MatBoolCrit,
HistParamR = HistParamR, HistCrit = HistCrit * Multiplier,
MatBoolCrit = MatBoolCrit,
CritName = CritName, CritBestValue = CritBestValue)
class(OutputsCalib) <- c("OutputsCalib", "HBAN")
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