adding fix domain

Author: edwindj

DESCRIPTION

@@ -12,10 +12,9 @@ Description: Rule sets with validation rules may contain redundancies or contrad
 Depends: validate
 License: MIT + file LICENSE
 Encoding: UTF-8
-LazyData: true
 URL: https://github.com/data-cleaning/validatetools
 BugReports: https://github.com/data-cleaning/validatetools/issues
 Imports: methods, stats, utils, lpSolveAPI
 Suggests: testthat,
     covr
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2

NAMESPACE

@@ -2,6 +2,7 @@
 
 S3method("[",dnf)
 S3method(as.character,dnf)
+S3method(as.character,mip_rule)
 S3method(as.expression,dnf)
 S3method(print,dnf)
 S3method(print,mip_rule)

R/detect_boundary.R

@@ -11,7 +11,7 @@
 #' @example ./examples/detect_boundary.R
 #' @export
 #' @param x \code{\link{validator}} object, rule set to be checked
-#' @param eps detected fixed values will have this precission.
+#' @param eps detected fixed values will have this precision.
 #' @param ... currently not used
 #' @family feasibility
 #' @return \code{\link{data.frame}} with columns "variable", "lowerbound", "upperbound".

R/dnf.R

@@ -237,9 +237,36 @@ to_miprules <- function(x, ...){
 to_lp <- function(x, objective = NULL, eps = 0.001){
   check_validator(x, check_infeasible = FALSE)
   rules <- to_miprules(x)
+  rules <- fix_cat_domain(rules)
   translate_mip_lp(rules = rules, objective = objective, eps = eps)
 }
 
+# make sure that the values of each categorical variable are exclusive
+# which is not guaranteed when no domain is given
+fix_cat_domain <- function(rules){
+  type <- get_mr_type(rules)
+  binvars <- names(type)[type == "binary"]
+  if (length(binvars) == 0){
+    return(rules)
+  }
+  
+  catvars <- 
+    strsplit(binvars, INFIX_CAT_NAME)
+  
+  catvars <- sapply(catvars, function(x){
+      x[[1]]
+    })
+  
+  cv <- 
+    split(binvars, catvars) |> 
+    lapply(function(x){
+      a <- sapply(x, \(x) 1)
+      type <- sapply(x, \(x) "binary")
+      mip_rule(a = a, op = "<=", b = 1, rule = "domain", type = type)
+    })
+  c(rules, unname(cv))
+}
+
 # as_dnf(quote(!(gender == "male") | x > 6))
 # as_dnf(quote(if (y == 1) x > 6))
 # as_dnf(quote( !(gender %in% "male" & y > 3) | x > 6))

R/feasible.R

@@ -66,6 +66,7 @@ detect_infeasible_rules <- function(x, weight = numeric(), ...){
   }
 
   mr <- to_miprules(x)
+  mr <- fix_cat_domain(mr)
 
   is_equality <- sapply(mr, function(m){
     m$op == "==" && all(m$type == "double")
@@ -87,7 +88,6 @@ detect_infeasible_rules <- function(x, weight = numeric(), ...){
 
   # make all rules soft rules
   objective <- numeric()
-  
   mr <- lapply(mr , function(r){
     is_lin <- all(r$type == "double")
     is_cat <- all(r$type == "binary")

R/mip_lpsolve.R

@@ -10,7 +10,7 @@ translate_mip_lp <- function( rules
                             , objective=NULL
                             , eps = 1e-3
                             ){
-  #browser()
+  
   lc <- get_mr_matrix(rules)
   type <- get_mr_type(rules)
 

R/mip_rule.R

@@ -18,6 +18,7 @@ mip_rule <- function(a, op, b, rule, type, weight=Inf, ...){
            )
 }
 
+#' @export
 as.character.mip_rule <- function(x, ...){
   a <- paste0(x$a, "*", names(x$a), collapse= ' + ')
 

R/validatetools-package.R

@@ -37,5 +37,4 @@
 #' @importFrom stats setNames
 #' @importFrom utils head tail
 #' @import validate
-#' @docType package
-NULL
+"_PACKAGE"