R/086_atoms_elementwise_logic.R

In CVXR: Disciplined Convex Optimization

#####
## DO NOT EDIT THIS FILE!! EDIT THE SOURCE INSTEAD: rsrc_tree/atoms/elementwise/logic.R
#####

## CVXPY SOURCE: atoms/elementwise/logic.py
## Boolean logic atoms: Not, And, Or, Xor + implies/iff convenience functions


# -- Helper: check if argument is valid boolean logic input --------
.is_boolean_arg <- function(arg) {
  if (.s7_is(arg, LogicExpression)) return(TRUE)
  ## CVXPY SOURCE: logic.py:29-30 -- `isinstance(arg, Leaf) and
  ## arg.attributes.get('boolean')`, a TRUTHINESS test, so a partial index list
  ## qualifies. `isTRUE()` does not: it is FALSE for every index spelling, so
  ## `And(Variable(2, boolean = c(1)), ...)` raised in CVXR and builds in CVXPY.
  ## Reading `@.boolean_idx` is both the fix and the consistent choice -- it is
  ## the canonical index set the solver path and project() use.
  if (.s7_is(arg, Leaf) && length(arg@.boolean_idx) > 0L) return(TRUE)
  if (.s7_is(arg, Constant)) {
    ## DELIBERATE DEVIATION from logic.py:31-33, which reads
    ## `Constant.is_boolean_valued` -- a flag recorded in __init__ from the
    ## ORIGINAL numpy dtype (constant.py:46,70-77) before const_to_matrix casts
    ## to float64. That rule is a numpy artifact: it makes `Constant(np.array(
    ## [1, 1]))` NOT boolean while `Constant(np.array([1, 1], dtype=bool))` is.
    ## R has no such split -- `c(1, 1)` and `c(TRUE, TRUE)` are interchangeable
    ## in ordinary use -- so CVXR asks what the value IS rather than how it was
    ## typed, and accepts both. Consequence, stated plainly: CVXR builds
    ## `And(x, Constant(c(1, 1)))` where CVXPY 1.9.2 raises.
    ##
    ## Two guards the bare `all(v == 0 | v == 1)` was missing:
    ##
    ##   NA/NaN -- `all()` over a comparison against NaN returns NA, and the
    ##     caller does `if (!.is_boolean_arg(arg))`, so `And(b, Constant(c(NaN,
    ##     1)))` died with R's "missing value where TRUE/FALSE needed" instead
    ##     of the message this function exists to produce. Same defect class as
    ##     the one fixed in `.validate_leaf_value`: an NA-propagating predicate
    ##     feeding an `if`. A value that is not a number is not boolean.
    ##
    ##   empty -- `all(logical(0))` is TRUE, so a zero-size Constant was
    ##     reported boolean by vacuous truth.
    ##
    ## NOT guarded, and inherent to a value-based rule: exact comparison means
    ## acceptance depends on how a value was COMPUTED. `0.1 * 10` and
    ## `0.3 / 0.3` are exactly 1 and pass; `sqrt(2)^2 - 1` is 0.9999999999999998
    ## and does not. A tolerance would substitute one arbitrary rule for
    ## another, so the exactness is kept and documented rather than fudged.
    v <- value(arg)
    if (is.null(v) || length(v) == 0L) return(FALSE)
    ok <- (v == 0L) | (v == 1L)
    return(!anyNA(ok) && all(ok))
  }
  FALSE
}

# ===================================================================
# LogicExpression -- abstract base class for boolean logic atoms
# ===================================================================

LogicExpression <- new_class("LogicExpression", parent = Elementwise,
  package = "CVXR",
  constructor = function(args, id = NULL) {
    if (FALSE) new_object(S7_object())  ## S7 static-check guard
    if (is.null(id)) id <- next_expr_id()
    args <- lapply(args, as_expr)
    if (length(args) == 0L)
      cli_abort("No arguments given to {.cls LogicExpression}.")
    shape <- sum_shapes(lapply(args, function(a) .shape(a)))
    obj <- .fast_new(LogicExpression, S7_object(),
      id     = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args   = args,
      shape  = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- validate_arguments --------------------------------------------
method(validate_arguments, LogicExpression) <- function(x) {
  ## Check broadcastable shapes (parent Elementwise validation)
  sum_shapes(lapply(.args(x), function(a) .shape(a)))
  ## Check all args are boolean

  for (arg in .args(x)) {
    if (!.is_boolean_arg(arg)) {
      cli_abort(
        "All arguments to {.cls {class(x)[[1L]]}} must be boolean variables or LogicExpression instances."
      )
    }
  }
  invisible(NULL)
}

# -- sign: result is boolean (0 or 1), so nonneg ------------------
method(sign_from_args, LogicExpression) <- function(x) {
  list(is_nonneg = TRUE, is_nonpos = FALSE)
}

# -- curvature: both convex and concave (affine-like for DCP) -----
method(is_atom_convex, LogicExpression) <- function(x) TRUE
method(is_atom_concave, LogicExpression) <- function(x) TRUE

# -- monotonicity: default FALSE ----------------------------------
method(is_incr, LogicExpression) <- function(x, idx, ...) FALSE
method(is_decr, LogicExpression) <- function(x, idx, ...) FALSE

# ===================================================================
# Not -- logical NOT of a boolean expression
# ===================================================================

#' Logical NOT
#'
#' Returns `1 - x`, flipping 0 to 1 and 1 to 0.
#' Can also be written with the `!` operator: `!x`.
#'
#' @param x A boolean \link{Variable} or logic expression.
#' @param id Optional integer ID (internal use).
#' @returns A \code{Not} expression.
#' @seealso [And()], [Or()], [Xor()], [implies()], [iff()]
#' @examples
#' \dontrun{
#' x <- Variable(boolean = TRUE)
#' not_x <- !x          # operator syntax
#' not_x <- Not(x)      # functional syntax
#' }
#' @export
Not <- new_class("Not", parent = LogicExpression, package = "CVXR",
  constructor = function(x, id = NULL) {
    if (FALSE) new_object(S7_object())  ## S7 static-check guard
    if (is.null(id)) id <- next_expr_id()
    x <- as_expr(x)
    shape <- .shape(x)
    obj <- .fast_new(Not, S7_object(),
      id     = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args   = list(x),
      shape  = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- validate: exactly 1 arg --------------------------------------
method(validate_arguments, Not) <- function(x) {
  if (length(.args(x)) != 1L)
    cli_abort("{.cls Not} takes exactly 1 argument.")
  ## Parent validation (boolean check)
  for (arg in .args(x)) {
    if (!.is_boolean_arg(arg))
      cli_abort(
        "All arguments to {.cls Not} must be boolean variables or LogicExpression instances."
      )
  }
  invisible(NULL)
}

# -- monotonicity: decreasing (flips sign) ------------------------
method(is_decr, Not) <- function(x, idx, ...) TRUE

# -- numeric ------------------------------------------------------
method(numeric_value, Not) <- function(x, values, ...) {
  1 - values[[1L]]
}

# -- name ---------------------------------------------------------
method(expr_name, Not) <- function(x) {
  child <- .args(x)[[1L]]
  child_name <- expr_name(child)
  if (.s7_is(child, NaryLogicExpression)) {
    paste0("!(", child_name, ")")
  } else {
    paste0("!", child_name)
  }
}

## CVXPY SOURCE: atoms/elementwise/logic.py Not.format_labeled.
method(format_labeled, Not) <- function(x) {
  lbl <- label(x)
  if (!is.null(lbl)) return(lbl)
  child <- .args(x)[[1L]]
  child_name <- format_labeled(child)
  if (.s7_is(child, NaryLogicExpression)) {
    paste0("!(", child_name, ")")
  } else {
    paste0("!", child_name)
  }
}

# ===================================================================
# NaryLogicExpression -- shared base for n-ary logic atoms
# ===================================================================

NaryLogicExpression <- new_class("NaryLogicExpression",
  parent = LogicExpression, package = "CVXR",
  constructor = function(args, id = NULL) {
    if (FALSE) new_object(S7_object())  ## S7 static-check guard
    if (length(args) < 2L)
      cli_abort("N-ary logic expressions require at least 2 arguments.")
    if (is.null(id)) id <- next_expr_id()
    args <- lapply(args, as_expr)
    shape <- sum_shapes(lapply(args, function(a) .shape(a)))
    obj <- .fast_new(NaryLogicExpression, S7_object(),
      id     = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args   = args,
      shape  = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- validate: at least 2 args ------------------------------------
method(validate_arguments, NaryLogicExpression) <- function(x) {
  if (length(.args(x)) < 2L)
    cli_abort("N-ary logic expressions require at least 2 arguments.")
  ## Parent validation (boolean check)
  for (arg in .args(x)) {
    if (!.is_boolean_arg(arg))
      cli_abort(
        "All arguments to {.cls {class(x)[[1L]]}} must be boolean variables or LogicExpression instances."
      )
  }
  invisible(NULL)
}

# ===================================================================
# And -- logical AND of boolean expressions
# ===================================================================

#' Logical AND
#'
#' Returns 1 if and only if all arguments equal 1, and 0 otherwise.
#' For two operands, can also be written with the `&` operator: `x & y`.
#'
#' @param ... Two or more boolean \link{Variable}s or logic expressions.
#' @param id Optional integer ID (internal use).
#' @returns An \code{And} expression.
#' @seealso [Not()], [Or()], [Xor()], [implies()], [iff()]
#' @examples
#' \dontrun{
#' x <- Variable(boolean = TRUE)
#' y <- Variable(boolean = TRUE)
#' both <- x & y            # operator syntax
#' both <- And(x, y)        # functional syntax
#' all3 <- And(x, y, z)     # n-ary
#' }
#' @export
And <- new_class("And", parent = NaryLogicExpression, package = "CVXR",
  constructor = function(..., id = NULL) {
    if (FALSE) new_object(S7_object())  ## S7 static-check guard
    args <- list(...)
    if (length(args) < 2L)
      cli_abort("{.cls And} requires at least 2 arguments.")
    if (is.null(id)) id <- next_expr_id()
    args <- lapply(args, as_expr)
    shape <- sum_shapes(lapply(args, function(a) .shape(a)))
    obj <- .fast_new(And, S7_object(),
      id     = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args   = args,
      shape  = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- monotonicity: increasing -------------------------------------
method(is_incr, And) <- function(x, idx, ...) TRUE

# -- numeric ------------------------------------------------------
method(numeric_value, And) <- function(x, values, ...) {
  Reduce(pmin, values)
}

# -- name ---------------------------------------------------------
method(expr_name, And) <- function(x) {
  parts <- vapply(.args(x), function(a) {
    nm <- expr_name(a)
    if (.s7_is(a, LogicExpression) &&
        (.s7_is(a, Or) || .s7_is(a, Xor))) {
      paste0("(", nm, ")")
    } else {
      nm
    }
  }, character(1))
  paste(parts, collapse = " & ")
}

## CVXPY SOURCE: atoms/elementwise/logic.py And.format_labeled
## (via _NaryLogicExpression._format_child with use_labels=True).
method(format_labeled, And) <- function(x) {
  lbl <- label(x)
  if (!is.null(lbl)) return(lbl)
  parts <- vapply(.args(x), function(a) {
    nm <- format_labeled(a)
    if (.s7_is(a, LogicExpression) &&
        (.s7_is(a, Or) || .s7_is(a, Xor))) {
      paste0("(", nm, ")")
    } else {
      nm
    }
  }, character(1))
  paste(parts, collapse = " & ")
}

# ===================================================================
# Or -- logical OR of boolean expressions
# ===================================================================

#' Logical OR
#'
#' Returns 1 if and only if at least one argument equals 1, and 0 otherwise.
#' For two operands, can also be written with the `|` operator: `x | y`.
#'
#' @param ... Two or more boolean \link{Variable}s or logic expressions.
#' @param id Optional integer ID (internal use).
#' @returns An \code{Or} expression.
#' @seealso [Not()], [And()], [Xor()], [implies()], [iff()]
#' @examples
#' \dontrun{
#' x <- Variable(boolean = TRUE)
#' y <- Variable(boolean = TRUE)
#' either <- x | y          # operator syntax
#' either <- Or(x, y)       # functional syntax
#' any3 <- Or(x, y, z)      # n-ary
#' }
#' @export
Or <- new_class("Or", parent = NaryLogicExpression, package = "CVXR",
  constructor = function(..., id = NULL) {
    if (FALSE) new_object(S7_object())  ## S7 static-check guard
    args <- list(...)
    if (length(args) < 2L)
      cli_abort("{.cls Or} requires at least 2 arguments.")
    if (is.null(id)) id <- next_expr_id()
    args <- lapply(args, as_expr)
    shape <- sum_shapes(lapply(args, function(a) .shape(a)))
    obj <- .fast_new(Or, S7_object(),
      id     = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args   = args,
      shape  = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- monotonicity: increasing -------------------------------------
method(is_incr, Or) <- function(x, idx, ...) TRUE

# -- numeric ------------------------------------------------------
method(numeric_value, Or) <- function(x, values, ...) {
  Reduce(pmax, values)
}

# -- name ---------------------------------------------------------
method(expr_name, Or) <- function(x) {
  ## Or has lowest precedence; no children need parens
  parts <- vapply(.args(x), expr_name, character(1))
  paste(parts, collapse = " | ")
}

## CVXPY SOURCE: atoms/elementwise/logic.py Or.format_labeled.
method(format_labeled, Or) <- function(x) {
  lbl <- label(x)
  if (!is.null(lbl)) return(lbl)
  parts <- vapply(.args(x), format_labeled, character(1))
  paste(parts, collapse = " | ")
}

# ===================================================================
# Xor -- logical XOR of boolean expressions
# ===================================================================

#' Logical XOR
#'
#' For two arguments: result is 1 iff exactly one is 1.
#' For n arguments: result is 1 iff an odd number are 1 (parity).
#'
#' Note: R's `^` operator is used for [power()], so `Xor` is functional syntax only.
#'
#' @param ... Two or more boolean \link{Variable}s or logic expressions.
#' @param id Optional integer ID (internal use).
#' @returns A \code{Xor} expression.
#' @seealso [Not()], [And()], [Or()], [implies()], [iff()]
#' @examples
#' \dontrun{
#' x <- Variable(boolean = TRUE)
#' y <- Variable(boolean = TRUE)
#' exclusive <- Xor(x, y)
#' }
#' @export
Xor <- new_class("Xor", parent = NaryLogicExpression, package = "CVXR",
  constructor = function(..., id = NULL) {
    if (FALSE) new_object(S7_object())  ## S7 static-check guard
    args <- list(...)
    if (length(args) < 2L)
      cli_abort("{.cls Xor} requires at least 2 arguments.")
    if (is.null(id)) id <- next_expr_id()
    args <- lapply(args, as_expr)
    shape <- sum_shapes(lapply(args, function(a) .shape(a)))
    obj <- .fast_new(Xor, S7_object(),
      id     = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args   = args,
      shape  = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- numeric ------------------------------------------------------
method(numeric_value, Xor) <- function(x, values, ...) {
  Reduce(function(a, b) (a + b) %% 2, values)
}

# -- name ---------------------------------------------------------
method(expr_name, Xor) <- function(x) {
  parts <- vapply(.args(x), function(a) {
    nm <- expr_name(a)
    ## Or has lower precedence than ^, so parenthesize it
    if (.s7_is(a, Or)) {
      paste0("(", nm, ")")
    } else {
      nm
    }
  }, character(1))
  paste(parts, collapse = " XOR ")
}

## CVXPY SOURCE: atoms/elementwise/logic.py Xor.format_labeled.
method(format_labeled, Xor) <- function(x) {
  lbl <- label(x)
  if (!is.null(lbl)) return(lbl)
  parts <- vapply(.args(x), function(a) {
    nm <- format_labeled(a)
    if (.s7_is(a, Or)) {
      paste0("(", nm, ")")
    } else {
      nm
    }
  }, character(1))
  paste(parts, collapse = " XOR ")
}

# ===================================================================
# Convenience functions
# ===================================================================

#' Logical Implication
#'
#' Logical implication: x => y.
#' Returns 1 unless x = 1 and y = 0. Equivalent to `Or(Not(x), y)`.
#'
#' @param x,y Boolean \link{Variable}s or logic expressions.
#' @returns An \link{Or} expression representing \code{!x | y}.
#' @seealso [iff()], [Not()], [And()], [Or()], [Xor()]
#' @examples
#' \dontrun{
#' x <- Variable(boolean = TRUE)
#' y <- Variable(boolean = TRUE)
#' expr <- implies(x, y)
#' }
#' @export
implies <- function(x, y) {
  Or(Not(x), y)
}

#' Logical Biconditional
#'
#' Logical biconditional: x <=> y.
#' Returns 1 if and only if x and y have the same value.
#' Equivalent to `Not(Xor(x, y))`.
#'
#' @param x,y Boolean \link{Variable}s or logic expressions.
#' @returns A \link{Not} expression wrapping \link{Xor}.
#' @seealso [implies()], [Not()], [And()], [Or()], [Xor()]
#' @examples
#' \dontrun{
#' x <- Variable(boolean = TRUE)
#' y <- Variable(boolean = TRUE)
#' expr <- iff(x, y)
#' }
#' @export
iff <- function(x, y) {
  Not(Xor(x, y))
}