R/130_transforms_indicator.R

In CVXR: Disciplined Convex Optimization

#####
## DO NOT EDIT THIS FILE!! EDIT THE SOURCE INSTEAD: rsrc_tree/transforms/indicator.R
#####

## CVXPY SOURCE: transforms/indicator.py
## Indicator -- indicator function for constraints
##
## An expression that equals 0 if all constraints hold, +Inf otherwise.
## This is convex and nonneg by definition.


Indicator <- new_class("Indicator", parent = Expression, package = "CVXR",
  properties = list(
    err_tol = class_double
  ),
  constructor = function(constraints, err_tol = 1e-3) {
    id <- next_expr_id()
    ## constraints is a list of Constraint objects stored as args
    if (!is.list(constraints)) constraints <- list(constraints)
    shape <- c(1L, 1L)

    new_object(S7_object(),
      id      = as.integer(id),
      .cache  = new.env(parent = emptyenv()),
      args    = constraints,
      shape   = shape,
      err_tol = as.double(err_tol)
    )
  }
)

# -- is_constant --------------------------------------------------
## CVXPY: indicator.py lines 43-48
## Indicator is constant if all constraint args are constant.
method(is_constant, Indicator) <- function(x) {
  all_args <- unlist(lapply(x@args, function(c) c@args), recursive = FALSE)
  all(vapply(all_args, is_constant, logical(1)))
}

# -- curvature ----------------------------------------------------
## CVXPY: indicator.py lines 50-58
method(is_convex, Indicator) <- function(x) TRUE
method(is_concave, Indicator) <- function(x) FALSE
method(is_log_log_convex, Indicator) <- function(x) FALSE
method(is_log_log_concave, Indicator) <- function(x) FALSE

# -- sign ---------------------------------------------------------
## CVXPY: indicator.py lines 60-75 -- always nonneg, never nonpos
method(is_nonneg, Indicator) <- function(x) TRUE
method(is_nonpos, Indicator) <- function(x) FALSE

# -- imaginary / complex -----------------------------------------
## CVXPY: indicator.py lines 77-84
method(is_imag, Indicator) <- function(x) FALSE
method(is_complex, Indicator) <- function(x) FALSE

# -- get_data -----------------------------------------------------
## CVXPY: indicator.py lines 86-89 -- [err_tol]
method(get_data, Indicator) <- function(x) list(x@err_tol)

# -- name ---------------------------------------------------------
## CVXPY: indicator.py lines 102-105
method(expr_name, Indicator) <- function(x) {
  arg_names <- vapply(x@args, function(c) {
    if (S7_inherits(c, Canonical)) expr_name(c) else as.character(c)
  }, character(1))
  paste0("Indicator(", paste(arg_names, collapse = ", "), ")")
}

# -- domain -------------------------------------------------------
## CVXPY: indicator.py lines 107-111 -- the constraints themselves
method(domain, Indicator) <- function(x) x@args

# -- value --------------------------------------------------------
## CVXPY: indicator.py lines 113-123
## Returns 0 if all constraints satisfied (within err_tol), Inf otherwise.
method(value, Indicator) <- function(x) {
  tol <- x@err_tol
  for (con in x@args) {
    res <- residual(con)
    if (is.null(res) || any(res > tol)) return(Inf)
  }
  0.0
}

# -- is_dpp -------------------------------------------------------
## CVXPY: indicator.py lines 97-100
method(is_dpp, Indicator) <- function(x, ...) FALSE

# -- variables / parameters / constants ---------------------------
## Collect from all constraint args
method(variables, Indicator) <- function(x) {
  unique(unlist(lapply(x@args, function(c) {
    if (S7_inherits(c, Canonical)) variables(c) else list()
  }), recursive = FALSE))
}

method(parameters, Indicator) <- function(x) {
  unique(unlist(lapply(x@args, function(c) {
    if (S7_inherits(c, Canonical)) parameters(c) else list()
  }), recursive = FALSE))
}

method(constants, Indicator) <- function(x) {
  unique(unlist(lapply(x@args, function(c) {
    if (S7_inherits(c, Canonical)) constants(c) else list()
  }), recursive = FALSE))
}

# ==================================================================
# Convenience function
# ==================================================================

#' Indicator function for constraints
#'
#' Creates an expression that equals 0 if all constraints are satisfied
#' and +Inf otherwise. Use this to embed constraints into the objective.
#'
#' @param constraints A list of constraint objects
#' @param err_tol Numeric tolerance for checking constraint satisfaction (default 1e-3)
#' @returns An Indicator expression
#' @export
indicator <- function(constraints, err_tol = 1e-3) {
  Indicator(constraints, err_tol)
}