initial commit to add function setThematicTrimming + tests

NAMESPACE

@@ -72,6 +72,7 @@ export(searchStudy)
 export(setAPImode)
 export(setPlaylist)
 export(setSolverPath)
+export(setThematicTrimming)
 export(storage_values_default)
 export(updateAdequacySettings)
 export(updateGeneralSettings)

R/thematic_trimming.R

@@ -0,0 +1,219 @@
+
+#' @title Set the thematic trimming of an Antares Study
+#'
+#' @description Put only variables names you want to keep in study output. 
+#' 
+#' you can add or remove variables.
+#'
+#' @param selection_variables `character` of variables to add or remove.
+#' @param type_select `character` select mode to add or remove (default add mode).
+#' @template opts
+#' 
+#' @note You can put only variables according to version of study
+#' 
+#' @export
+#' 
+#' @examples 
+#' \dontrun{
+#' 
+#' # list of variables (from version v8.0 to version >= v8.6)
+#' vect_select_vars <- antaresRead:::pkgEnv$thematic
+#' 
+#' ##
+#' # add all variables
+#' ##
+#' setThematicTrimming(selection_variables = vect_select_vars$variable)
+#' 
+#' ##
+#' # remove all variables
+#' ##
+#' setThematicTrimming(selection_variables = vect_select_vars$variable, 
+#' type_select = "suppr")
+#' 
+#' }
+setThematicTrimming <- function(selection_variables, 
+ type_select = c("add", "suppr"),
+ opts = simOptions()){
+
+ # available only for study version >= 800
+ if(opts$antaresVersion<800)
+ stop("'setThematicTrimming()' calls is only available for study version >= v8.0", 
+ call. = FALSE)
+
+ # basics parameters checks
+ assertthat::assert_that(inherits(opts, "simOptions"))
+ assertthat::assert_that(inherits(selection_variables, "character"))
+ type_select <- match.arg(type_select)
+
+ # checks whether the variables agree with the version
+ # at least one variable must be present in the list 
+ variables_package_list <- antaresRead:::pkgEnv$thematic
+
+ # filter with version
+ variables_package_list <- variables_package_list[
+ variables_package_list$version<=opts$antaresVersion, variable]
+
+ is_selection_ok <- any(
+ selection_variables %in%
+ variables_package_list
+ )
+
+ if(!is_selection_ok)
+ stop(paste0("Put only variables according too version of study : "), 
+ opts$antaresVersion, 
+ call. = FALSE)
+
+ # read general data parameters
+ generaldata <- readIni("settings/generaldata", 
+ opts = opts)
+
+ # update [general] (used to custom variable selection in Antares UI)
+ generaldata$general$`thematic-trimming` <- TRUE
+
+ # manage writing general data
+ generaldata_updated <- .set_thematic(type_select = type_select, 
+ pkg_var_version = variables_package_list, 
+ list_var_selection = selection_variables, 
+ general_data = generaldata, 
+ api_mode = antaresRead:::is_api_study(opts = opts))
+
+ # write updated file
+ writeIni(listData = generaldata_updated, 
+ pathIni = "settings/generaldata", 
+ overwrite = TRUE, 
+ opts = opts)
+
+ # Update simulation options object
+ if(antaresRead:::is_api_study(opts = opts)){
+ suppressWarnings(
+ res <- antaresRead::setSimulationPathAPI(host = opts$host,
+ study_id = opts$study_id, 
+ token = opts$token, 
+ simulation = "input")
+ )
+ }else{
+ suppressWarnings(
+ res <- antaresRead::setSimulationPath(path = opts$studyPath, 
+ simulation = "input")
+ )
+ }
+
+ invisible(res)
+
+}
+
+
+# according to UI or API 
+ # write in generaldata file only the fewest variables 
+ # Ex : you want ADD 90% of variables => write to SUPPR 10% 
+.set_thematic <- function(type_select, 
+ pkg_var_version, 
+ list_var_selection,
+ general_data,
+ api_mode = FALSE){
+ # reset [variables selection]
+ general_data$`variables selection` <- NULL
+
+ # count variables to write
+ nb_var_version <- length(pkg_var_version)
+ index_var_selection <- pkg_var_version %in% 
+ list_var_selection
+ nb_right_var_selection <- sum(index_var_selection)
+
+ # case with all variables selected
+ if(nb_var_version==nb_right_var_selection){
+ if(type_select %in% "add"){
+ cat("All variables are selected, by defaut it's not required to edit 'generaldata.ini'")
+ # general_data$`variables selection` <- NULL
+ return(general_data)
+ }
+ else{
+ cat("All variables will be skiped")
+ general_data$`variables selection`$selected_vars_reset <- FALSE
+ return(general_data)
+ }
+ }
+
+ # write your selection
+ if(nb_right_var_selection<as.integer(nb_var_version/2)){
+ if(type_select %in% "add"){
+ var_select_bloc <- .make_thematic_list(var_selection = list_var_selection, 
+ api_mode = api_mode)
+ general_data$`variables selection` <- var_select_bloc
+ return(general_data)
+ }else{
+ var_select_bloc <- .make_thematic_list(var_selection = list_var_selection, 
+ pattern_list = "select_var -", 
+ type_select = "suppr",
+ api_mode = api_mode)
+ general_data$`variables selection` <- var_select_bloc
+ return(general_data)
+ }
+ # write the opposite 
+ }else{ 
+ # diff 
+ list_var_selection <- setdiff(pkg_var_version, list_var_selection)
+ if(type_select %in% "add"){
+ var_select_bloc <- .make_thematic_list(var_selection = list_var_selection, 
+ pattern_list = "select_var -", 
+ type_select = "suppr",
+ api_mode = api_mode)
+ general_data$`variables selection` <- var_select_bloc
+ return(general_data)
+ }else{
+ var_select_bloc <- .make_thematic_list(var_selection = list_var_selection, 
+ pattern_list = "select_var +", 
+ type_select = "add",
+ api_mode = api_mode)
+ general_data$`variables selection` <- var_select_bloc
+ return(general_data)
+ }
+ }
+
+
+
+
+
+}
+
+
+
+# list construction (section [variables selection]
+ # build list with pattern and type 
+.make_thematic_list <- function(pattern_list = "select_var +", 
+ type_select = "add",
+ var_selection, 
+ api_mode = FALSE){
+ # "add"
+ if(type_select %in% "add")
+ # init list
+ ll_init <- list(
+ selected_vars_reset = FALSE
+ )
+ else
+ # init list
+ ll_init <- list(
+ selected_vars_reset = TRUE
+ )
+
+ # update list
+ if(api_mode){
+ element_list <- paste("\'", var_selection, "\'", 
+ collapse = ",", sep = "")
+ element_list <- paste("[", element_list, "]", sep = "")
+ bloc_list <- list(element_list)
+ names(bloc_list) <- pattern_list
+ }else{
+ bloc_list <- lapply(var_selection, function(x){
+ x
+ })
+ names(bloc_list) <- rep(pattern_list, 
+ length(var_selection))
+ }
+
+ # add to init list
+ bloc_list <- append(ll_init, 
+ bloc_list)
+
+ return(bloc_list)
+}