Merge pull request #14 from SticsRPacks/Fix_constraints_use_with_sitlist

Fix constraints use with sit_list
SticsRPacks · Mar 1, 2024 · ca6f80a · ca6f80a
2 parents 8c387e6 + 8d4ff64
commit ca6f80a
Show file tree

Hide file tree

Showing 4 changed files with 18 additions and 10 deletions.
diff --git a/R/compute_eq_const.R b/R/compute_eq_const.R
@@ -22,7 +22,7 @@ compute_eq_const <- function(forced_param_values, param_values) {
  nrow = nrows)
  colnames(comp_forced_values) <- names(forced_param_values)
 
- for (irow in nrows) {
+ for (irow in 1:nrows) {
 
  expr_ls <-
  lapply(names(forced_param_values), function(x) paste(x,"<-",forced_param_values[[x]]))

diff --git a/R/main_crit.R b/R/main_crit.R
@@ -56,7 +56,7 @@ main_crit <- function(param_values, crit_options) {
  ## should be changed for more robust test later ...
 
  if ((.croptEnv$eval_count == 1) ||
- (crit_options$irep > .croptEnv$params_and_crit[[.croptEnv$eval_count - 1]]$rep)) {
+ (crit_options$irep > tail(.croptEnv$params_and_crit[[.croptEnv$eval_count - 1]]$rep,1))) {
  eval <- 1
  iter <- NA
  .croptEnv$last_iter <- 0
@@ -66,7 +66,7 @@ main_crit <- function(param_values, crit_options) {
  .croptEnv$last_iter <- iter
  }
  } else {
- eval <- .croptEnv$params_and_crit[[.croptEnv$eval_count - 1]]$eval + 1
+ eval <- tail(.croptEnv$params_and_crit[[.croptEnv$eval_count - 1]]$eval,1) + 1
  iter <- NA
  if (!is.na(crit) && (is.na(.croptEnv$last_crit) ||
  crit < .croptEnv$last_crit)) {
@@ -165,8 +165,7 @@ main_crit <- function(param_values, crit_options) {
  situation_names <- names(obs_list)
  param_names_sl <- get_params_names(param_info, short_list = TRUE)
  crit <- NA
- model_results <- NA
- obs_sim_list <- NA
+ obs_sim_list <- NULL
  sim_transformed <- NULL
  model_results <- NULL
  sim <- NULL

diff --git a/R/optim_switch.R b/R/optim_switch.R
@@ -32,24 +32,32 @@ optim_switch <- function(...) {
 
  # Save results even in case parameter estimation crash
  res$obs_var_list <- .croptEnv$obs_var_list
- rm("obs_var_list", envir = .croptEnv)
+ if (exists(".croptEnv$obs_var_list")) {
+ rm("obs_var_list", envir = .croptEnv)
+ }
 
  if (arguments$crit_options$info_level >= 1) {
  res$params_and_crit <- dplyr::bind_rows(.croptEnv$params_and_crit)
- rm("params_and_crit", envir = .croptEnv)
+ if (exists(".croptEnv$params_and_crit")) {
+ rm("params_and_crit", envir = .croptEnv)
+ }
  }
  if (arguments$crit_options$info_level >= 2) {
  res$sim_intersect <- .croptEnv$sim_intersect
- rm("sim_intersect", envir = .croptEnv)
+ if (exists(".croptEnv$sim_intersect")) {
+ rm("sim_intersect", envir = .croptEnv)
+ }
  }
  if (arguments$crit_options$info_level >= 3) {
  res$obs_intersect <- .croptEnv$obs_intersect
- rm("obs_intersect", envir = .croptEnv)
+ if (exists(".croptEnv$obs_intersect")) {
+ rm("obs_intersect", envir = .croptEnv)
+ }
  }
  if (arguments$crit_options$info_level >= 4) {
  res$sim <- .croptEnv$sim
  res$sim_transformed <- .croptEnv$sim_transformed
- if (!is.null(res$sim_transformed)) {
+ if (exists(".croptEnv$sim_transformed")) {
  rm("sim_transformed", envir = .croptEnv)
  }
  }

diff --git a/R/param_info_functions.R b/R/param_info_functions.R
@@ -452,6 +452,7 @@ complete_init_values <- function(param_info, nb_values, ranseed = NULL,
  }))
  sampled_values <- sampled_values[idx, ]
  count <- 1
+ # sample values until the number of required values satisfying the constraints are reached
  while (nrow(sampled_values) < nb_values && count < 1000) {
  seed <- sample(1000, 1, replace = FALSE)
  sampled_tmp <- as.data.frame(sample_params(list(lb = lb, ub = ub), nb_values,