Control matrix dimension not at the first index

NEWS.md

@@ -21,7 +21,8 @@ BUGFIXES :
 * `createBindingConstraint()` in API mode (for study <v870) created with "hourly" timeStep all the time
 * `createBindingConstraint()` / `editBindingConstraint()` in TEXT mode, bad values in time series  
 * `createBindingConstraintBulk()` with no VALUES and with a mix 
-* side effects with `readClusterDesc()` / `readClusterResDesc()` / `readClusterSTDesc()` 
+* side effects with `readClusterDesc()` / `readClusterResDesc()` / `readClusterSTDesc()`
+* Enable control of matrix dimension in `.check_bulk_object_dim()` even if the values are not in first position in the list
 
 
 # antaresEditObject 0.7.0 

R/createBindingConstraint.R

@@ -42,7 +42,7 @@ utils::globalVariables(c('V2', 'dim_study', 'dim_input', 'name_group'))
 #' 
 #' @name createBindingConstraint
 #' 
-#' @importFrom antaresRead getLinks setSimulationPath
+#' @importFrom antaresRead getLinks setSimulationPath readIniFile
 #' @importFrom utils write.table
 #'
 #' @examples
@@ -168,11 +168,7 @@ createBindingConstraint <- function(name,
     if(is.null(group))
       group <- "default"
 
-    values_operator <- switch(operator,
-                              less = "lt",
-                              equal = "eq",
-                              greater = "gt",
-                              both = c("lt", "gt"))
+    values_operator <- switch_to_list_name_operator_870(operator)
 
     if(!is.null(values)){
       assertthat::assert_that(inherits(values, "list"))
@@ -673,6 +669,8 @@ group_values_meta_check <- function(group_value,
 #'  **Warning** all arguments for creating a binding constraints must be provided, see examples.
 #' @template opts
 #' @family binding constraints functions
+#'
+#' @importFrom antaresRead getLinks setSimulationPath readIniFile
 #' 
 #' @details 
 #' According to Antares version, usage may vary :
@@ -745,24 +743,19 @@ group_values_meta_check <- function(group_value,
 #' 
 createBindingConstraintBulk <- function(constraints,
                                         opts = antaresRead::simOptions()) {
-  assertthat::assert_that(inherits(opts, "simOptions"))
 
-  # check object dimension values only for versions >=8.7.0
-  if(opts$antaresVersion>=870)
-    .check_bulk_object_dim(constraints = constraints, 
-                           opts = opts)
-  ## Ini file
-  pathIni <- file.path(opts$inputPath, "bindingconstraints/bindingconstraints.ini")
-  bindingConstraints <- readIniFile(pathIni, stringsAsFactors = FALSE)
+  assertthat::assert_that(inherits(opts, "simOptions"))
 
+  if(opts[["antaresVersion"]] >= 870) {
+    # check matrix dimension
+    .check_bulk_object_dim(constraints = constraints, opts = opts)
+  }
 
+  pathIni <- file.path(opts$inputPath, "bindingconstraints", "bindingconstraints.ini")
+  bindingConstraints <- readIniFile(pathIni, stringsAsFactors = FALSE)
 
   for (i in seq_along(constraints)) {
-    values_operator <- switch(constraints[[i]]$operator,
-                              less = "lt",
-                              equal = "eq",
-                              greater = "gt",
-                              both = c("lt", "gt"))
+    values_operator <- switch_to_list_name_operator_870(constraints[[i]][["operator"]])
 
     bindingConstraints <- do.call("createBindingConstraint_", c(
       constraints[[i]],
@@ -780,6 +773,7 @@ createBindingConstraintBulk <- function(constraints,
   suppressWarnings({
     res <- antaresRead::setSimulationPath(path = opts$studyPath, simulation = "input")
   })
+
   invisible(res)
 }
 
@@ -794,33 +788,38 @@ createBindingConstraintBulk <- function(constraints,
   # In all_dim_group, group is column V1, number of columns is column V2
   all_dim_group <- do.call("rbind", 
                            c(lapply(constraints, function(x){
-                             data.table(name_group <- x$group,
-                                        dim_group <- dim(x$values[[1]])[2])}), 
-                             fill = TRUE))
+                               operator_symbol <- switch_to_list_name_operator_870(x[["operator"]])
+                               dim_matrix <- lapply(x[["values"]][which(names(x[["values"]]) %in% operator_symbol)], dim)
+                               data.table(rep(x[["group"]], length(dim_matrix)), sapply(dim_matrix, "[[", 2))
+                               }
+                            ), 
+                             fill = TRUE
+    )
+  )
 
   # If each matrix is NULL, there is no second dimension in the table
   if (dim(all_dim_group)[2] < 2) {
     return()
   }
 
-  # no duplicated 
-  all_dim_group <- unique(all_dim_group)
-  select_dim <- all_dim_group[V2>1]
+  # Deduplicate rows and filter V2 > 1
+  select_dim <- unique(all_dim_group)[V2 > 1]
 
-  # count
-  t_df <- table(select_dim)
-  check_row <- rowSums(t_df)
+  # Detect duplicated groups
+  duplicated_groups <- select_dim[duplicated(select_dim$V1),]$V1
 
-  if(any(check_row>1))
+  if (!identical(duplicated_groups, character(0))) {
     stop("Problem dimension with group : ", 
-         paste0(names(check_row[check_row>1]), sep = " "), 
+         paste0(duplicated_groups, sep = " "), 
          call. = FALSE)
+  }
 
   # check input object with study
-  if(is.null(opts$binding))
+  if (is.null(opts[["binding"]])) {
     return()
+  }
   else{
-    merge_groups <- merge.data.table(x = opts$binding, 
+    merge_groups <- merge.data.table(x = opts[["binding"]], 
                      y = select_dim, 
                      by.x ="name_group", 
                      by.y = "V1")
@@ -830,10 +829,25 @@ createBindingConstraintBulk <- function(constraints,
     # check diff 
     diff_dim <- merge_groups[dim_study!=dim_input]
 
-    if(nrow(diff_dim)>0)
+    if (nrow(diff_dim) > 0) {
       stop("Problem dimension with group in Study: ", 
            paste0(diff_dim$name_group, sep = " "), 
            call. = FALSE)
+    }
   }
 }
 
+
+switch_to_list_name_operator_870 <- function(operator) {
+
+  assertthat::assert_that(operator %in% c("less", "greater", "equal", "both"))
+
+  operator_symbol <- switch(operator,
+                            "less" = "lt",
+                            "equal" = "eq",
+                            "greater" = "gt",
+                            "both" = c("lt", "gt")
+                            )
+
+  return(operator_symbol)
+}

tests/testthat/test-createBindingConstraint.R

@@ -824,6 +824,48 @@ test_that("test mixed VALUES in study v8.7", {
 
 
 
+})
+
+
+test_that("test that control of matrix dimension is not dependent of the order in the list values", {
+
+  val_cstr1 <- list("lt" = matrix(data = rep(0, 8760 * 1), ncol = 1),
+                    "gt" = matrix(data = rep(555, 8760 * 3), ncol = 3),
+                    "eq" = matrix(data = rep(0, 8760 * 1), ncol = 1)
+                    )
+  val_cstr2 <- list("lt" = matrix(data = rep(0, 8760 * 1), ncol = 1),
+                    "eq" = matrix(data = rep(0, 8760 * 1), ncol = 1),
+                    "gt" = matrix(data = rep(777, 8760 * 5), ncol = 5)
+                    )
+  lst_cstr <- list(
+    list(
+      name = "cstr1", 
+      id = "cstr1",
+      values = val_cstr1, 
+      enabled = TRUE, 
+      timeStep = "hourly",
+      operator = "greater",
+      coefficients = list("at%fr" = 1),
+      group= "group_bulk_123",
+      overwrite = TRUE
+      ),
+    list(
+      name = "cstr2", 
+      id = "cstr2",
+      values = val_cstr2, 
+      enabled = TRUE, 
+      timeStep = "hourly",
+      operator = "greater",
+      coefficients = list("at%fr" = 1),
+      group= "group_bulk_123",
+      overwrite = TRUE
+      )
+  )
+  expect_error(
+    createBindingConstraintBulk(constraints = lst_cstr, opts = simOptions()), 
+    regexp = "Problem dimension with group"
+  )
+
 })
 
 # remove temporary study ----