R/027_atoms_atom.R

In CVXR: Disciplined Convex Optimization

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

## CVXPY SOURCE: atoms/atom.py
## Atom -- abstract base class for all atoms (operations on expressions)
##
## An Atom represents a mathematical function applied to one or more
## Expression arguments. The DCP composition rules are implemented here.


Atom <- new_class("Atom", parent = Expression, package = "CVXR",
  constructor = function(args, shape, id = NULL) {
    if (is.null(id)) id <- next_expr_id()
    args <- lapply(args, as_expr)
    if (length(args) == 0L) {
      cli_abort("No arguments given to {.cls Atom}.")
    }
    shape <- validate_shape(shape)
    obj <- new_object(S7_object(),
      id    = as.integer(id),
      .cache = new.env(parent = emptyenv()),
      args  = args,
      shape = shape
    )
    validate_arguments(obj)
    obj
  }
)

# -- validate_arguments ----------------------------------------------
## CVXPY SOURCE: atom.py lines 91-97
## Default: rejects complex arguments unless _allow_complex is TRUE.
## Subclasses override via validate_arguments generic.

method(validate_arguments, Atom) <- function(x) {
  if (.any_args(x, is_complex)) {
    cli_abort("Arguments to {.cls {class(x)[[1L]]}} cannot be complex.")
  }
  invisible(NULL)
}

# -- name -------------------------------------------------------------
## CVXPY SOURCE: atom.py lines 56-63

method(expr_name, Atom) <- function(x) {
  data <- get_data(x)
  data_str <- if (is.null(data)) character(0) else vapply(data, as.character, character(1))
  arg_strs <- vapply(x@args, expr_name, character(1))
  sprintf("%s(%s)", class(x)[[1L]], paste(c(arg_strs, data_str), collapse = ", "))
}

# -- Sign: cached, from sign_from_args --------------------------------
## CVXPY SOURCE: atom.py lines 115-125

method(is_nonneg, Atom) <- function(x) {
  cached <- cache_get(x, "is_nonneg")
  if (!cache_miss(cached)) return(cached)
  result <- sign_from_args(x)[["is_nonneg"]]
  cache_set(x, "is_nonneg", result)
  result
}

method(is_nonpos, Atom) <- function(x) {
  cached <- cache_get(x, "is_nonpos")
  if (!cache_miss(cached)) return(cached)
  result <- sign_from_args(x)[["is_nonpos"]]
  cache_set(x, "is_nonpos", result)
  result
}

# -- Complex: default FALSE ------------------------------------------
## CVXPY SOURCE: atom.py lines 127-139

method(is_imag, Atom) <- function(x) FALSE
method(is_complex, Atom) <- function(x) FALSE

# -- is_atom_affine: plain function ----------------------------------
## CVXPY SOURCE: atom.py lines 153-156

is_atom_affine <- function(x) is_atom_convex(x) && is_atom_concave(x)

# -- Log-log DGP atom hooks: default FALSE -------------------------
## CVXPY SOURCE: atom.py -- default is False
method(is_atom_log_log_convex, Atom) <- function(x) FALSE
method(is_atom_log_log_concave, Atom) <- function(x) FALSE

## is_atom_log_log_affine: convenience (CVXPY atom.py lines 178-181)
is_atom_log_log_affine <- function(x) {
  is_atom_log_log_concave(x) && is_atom_log_log_convex(x)
}

# -- DCP composition: is_convex / is_concave -------------------------
## CVXPY SOURCE: atom.py lines 195-227
## idx for is_incr/is_decr: 1-based (R convention)

method(is_convex, Atom) <- function(x) {
  key <- .dpp_key("is_convex")
  cached <- cache_get(x, key)
  if (!cache_miss(cached)) return(cached)
  result <- .atom_is_convex(x)
  cache_set(x, key, result)
  result
}

.atom_is_convex <- function(x) {
  if (is_constant(x)) return(TRUE)
  if (!is_atom_convex(x)) return(FALSE)
  for (idx in seq_along(x@args)) {
    arg <- x@args[[idx]]
    if (!(is_affine(arg) ||
          (is_convex(arg) && is_incr(x, idx)) ||
          (is_concave(arg) && is_decr(x, idx)))) {
      return(FALSE)
    }
  }
  TRUE
}

method(is_concave, Atom) <- function(x) {
  key <- .dpp_key("is_concave")
  cached <- cache_get(x, key)
  if (!cache_miss(cached)) return(cached)
  result <- .atom_is_concave(x)
  cache_set(x, key, result)
  result
}

.atom_is_concave <- function(x) {
  if (is_constant(x)) return(TRUE)
  if (!is_atom_concave(x)) return(FALSE)
  for (idx in seq_along(x@args)) {
    arg <- x@args[[idx]]
    if (!(is_affine(arg) ||
          (is_concave(arg) && is_incr(x, idx)) ||
          (is_convex(arg) && is_decr(x, idx)))) {
      return(FALSE)
    }
  }
  TRUE
}

# -- DQCP: quasiconvex / quasiconcave composition ------------------
## CVXPY SOURCE: atom.py lines 273-335

## Helper: indices of non-constant arguments (1-based, R convention)
.non_const_idx <- function(x) {
  idx <- integer(0)
  for (i in seq_along(x@args)) {
    if (!is_constant(x@args[[i]])) idx <- c(idx, i)
  }
  idx
}

## Helper: is this a "real" function? (scalar in, scalar out, one non-const arg)
## CVXPY SOURCE: atom.py lines 278-285
.is_real_fn <- function(x) {
  non_const <- .non_const_idx(x)
  expr_is_scalar(x) &&
    length(non_const) == 1L &&
    expr_is_scalar(x@args[[non_const[1L]]])
}

## Atom-level quasiconvex/quasiconcave hooks (defaults: fall back to DCP)
## CVXPY SOURCE: atom.py lines 159-167
method(is_atom_quasiconvex, Atom) <- function(x) is_atom_convex(x)
method(is_atom_quasiconcave, Atom) <- function(x) is_atom_concave(x)

## Quasiconvex composition (CVXPY atom.py lines 288-310)
method(is_quasiconvex, Atom) <- function(x) {
  cached <- cache_get(x, "is_quasiconvex")
  if (!cache_miss(cached)) return(cached)
  result <- .atom_is_quasiconvex(x)
  cache_set(x, "is_quasiconvex", result)
  result
}

.atom_is_quasiconvex <- function(x) {
  if (is_convex(x)) return(TRUE)
  ## Maximum / MaxEntries: all args quasiconvex
  if (S7_inherits(x, Maximum) || S7_inherits(x, MaxEntries)) {
    return(.all_args(x, is_quasiconvex))
  }
  ## Real function with monotone argument
  non_const <- .non_const_idx(x)
  if (.is_real_fn(x) && is_incr(x, non_const[1L])) {
    return(is_quasiconvex(x@args[[non_const[1L]]]))
  }
  if (.is_real_fn(x) && is_decr(x, non_const[1L])) {
    return(is_quasiconcave(x@args[[non_const[1L]]]))
  }
  ## Atom-level quasiconvex with DCP-like arg checks
  if (is_atom_quasiconvex(x)) {
    for (idx in seq_along(x@args)) {
      arg <- x@args[[idx]]
      if (!(is_affine(arg) ||
            (is_convex(arg) && is_incr(x, idx)) ||
            (is_concave(arg) && is_decr(x, idx)))) {
        return(FALSE)
      }
    }
    return(TRUE)
  }
  FALSE
}

## Quasiconcave composition (CVXPY atom.py lines 312-335)
method(is_quasiconcave, Atom) <- function(x) {
  cached <- cache_get(x, "is_quasiconcave")
  if (!cache_miss(cached)) return(cached)
  result <- .atom_is_quasiconcave(x)
  cache_set(x, "is_quasiconcave", result)
  result
}

.atom_is_quasiconcave <- function(x) {
  if (is_concave(x)) return(TRUE)
  ## Minimum / MinEntries: all args quasiconcave
  if (S7_inherits(x, Minimum) || S7_inherits(x, MinEntries)) {
    return(.all_args(x, is_quasiconcave))
  }
  ## Real function with monotone argument
  non_const <- .non_const_idx(x)
  if (.is_real_fn(x) && is_incr(x, non_const[1L])) {
    return(is_quasiconcave(x@args[[non_const[1L]]]))
  }
  if (.is_real_fn(x) && is_decr(x, non_const[1L])) {
    return(is_quasiconvex(x@args[[non_const[1L]]]))
  }
  ## Atom-level quasiconcave with DCP-like arg checks
  if (is_atom_quasiconcave(x)) {
    for (idx in seq_along(x@args)) {
      arg <- x@args[[idx]]
      if (!(is_affine(arg) ||
            (is_concave(arg) && is_incr(x, idx)) ||
            (is_convex(arg) && is_decr(x, idx)))) {
        return(FALSE)
      }
    }
    return(TRUE)
  }
  FALSE
}

# -- Log-log DCP -----------------------------------------------------
## CVXPY SOURCE: atom.py lines 240-271

method(is_log_log_convex, Atom) <- function(x) {
  cached <- cache_get(x, "is_log_log_convex")
  if (!cache_miss(cached)) return(cached)
  result <- .atom_is_log_log_convex(x)
  cache_set(x, "is_log_log_convex", result)
  result
}

.atom_is_log_log_convex <- function(x) {
  if (is_log_log_constant(x)) return(TRUE)
  if (!is_atom_log_log_convex(x)) return(FALSE)
  ## Check args satisfy DGP composition (CVXPY atom.py lines 247-253)
  for (i in seq_along(x@args)) {
    arg <- x@args[[i]]
    if (!(is_log_log_affine(arg) ||
          (is_log_log_convex(arg) && is_incr(x, i)) ||
          (is_log_log_concave(arg) && is_decr(x, i)))) {
      return(FALSE)
    }
  }
  TRUE
}

method(is_log_log_concave, Atom) <- function(x) {
  cached <- cache_get(x, "is_log_log_concave")
  if (!cache_miss(cached)) return(cached)
  result <- .atom_is_log_log_concave(x)
  cache_set(x, "is_log_log_concave", result)
  result
}

.atom_is_log_log_concave <- function(x) {
  if (is_log_log_constant(x)) return(TRUE)
  if (!is_atom_log_log_concave(x)) return(FALSE)
  ## Check args satisfy DGP composition (CVXPY atom.py lines 263-269)
  for (i in seq_along(x@args)) {
    arg <- x@args[[i]]
    if (!(is_log_log_affine(arg) ||
          (is_log_log_concave(arg) && is_incr(x, i)) ||
          (is_log_log_convex(arg) && is_decr(x, i)))) {
      return(FALSE)
    }
  }
  TRUE
}

# -- canonicalize ----------------------------------------------------
## CVXPY SOURCE: atom.py lines 337-356

method(canonicalize, Atom) <- function(x) {
  ## Constant atoms (with no parameters) -> wrap as Constant
  if (is_constant(x) && length(parameters(x)) == 0L) {
    return(canonical_form(Constant(value(x))))
  }
  ## Recursively canonicalize args
  arg_objs <- vector("list", length(x@args))
  constraints <- list()
  for (i in seq_along(x@args)) {
    cf <- canonical_form(x@args[[i]])
    arg_objs[[i]] <- cf[[1L]]
    constraints <- c(constraints, cf[[2L]])
  }
  ## Graph implementation
  data <- get_data(x)
  gi <- graph_implementation(x, arg_objs, x@shape, data)
  list(gi[[1L]], c(constraints, gi[[2L]]))
}

# -- value -----------------------------------------------------------
## CVXPY SOURCE: atom.py lines 379-403

method(value, Atom) <- function(x) {
  ## Check if any parameter lacks a value
  params <- parameters(x)
  if (length(params) > 0L) {
    for (p in params) {
      if (is.null(value(p))) return(NULL)
    }
  }
  ## Evaluate
  .atom_value_impl(x)
}

## Internal value implementation (recursive)
## CVXPY SOURCE: atom.py lines 385-403
.atom_value_impl <- function(x) {
  if (0L %in% x@shape) return(numeric(0))
  arg_values <- vector("list", length(x@args))
  for (i in seq_along(x@args)) {
    arg_val <- value(x@args[[i]])
    ## A NULL arg makes higher-level values NULL, unless atom is constant
    if (is.null(arg_val) && !is_constant(x)) return(NULL)
    arg_values[[i]] <- arg_val
  }
  numeric_value(x, arg_values)
}

# -- grad ------------------------------------------------------------
## CVXPY SOURCE: atom.py lines 405-453
## Chain rule: grad_self * grad_arg for each variable
## Stub for now -- full implementation requires _grad abstract method

method(grad, Atom) <- function(x) {
  cli_abort("grad() not yet implemented for {.cls Atom} subclasses.")
}

# -- domain ----------------------------------------------------------
## CVXPY SOURCE: atom.py lines 469-474
## self._domain() + [con for arg in self.args for con in arg.domain]

## Default atom_domain: no extra constraints
## CVXPY SOURCE: atom.py::_domain -- default returns []
method(atom_domain, Atom) <- function(x) list()

method(domain, Atom) <- function(x) {
  ## CVXPY: self._domain() + [con for arg in self.args for con in arg.domain]
  my_domain <- atom_domain(x)
  arg_domains <- unlist(lapply(x@args, domain), recursive = FALSE)
  if (is.null(arg_domains)) arg_domains <- list()
  c(my_domain, arg_domains)
}

# -- atoms -----------------------------------------------------------
## CVXPY SOURCE: atom.py lines 496-502
## Returns atom types present in the expression tree.
## In R, we collect S7 class objects, deduplicated by class name.

method(atoms, Atom) <- function(x) {
  nargs <- length(x@args)
  parts <- vector("list", nargs + 1L)
  for (i in seq_len(nargs)) {
    parts[[i]] <- atoms(x@args[[i]])
  }
  parts[[nargs + 1L]] <- list(S7_class(x))
  .unique_atom_types(unlist(parts, recursive = FALSE))
}

## Helper: deduplicate a list of S7 class objects by class name
.unique_atom_types <- function(class_list) {
  n <- length(class_list)
  if (n == 0L) return(list())
  seen <- new.env(hash = TRUE, parent = emptyenv())
  result <- vector("list", n)
  ri <- 0L
  for (cls in class_list) {
    name <- if (inherits(cls, "S7_class")) cls@name else as.character(cls)
    if (!exists(name, envir = seen, inherits = FALSE)) {
      assign(name, TRUE, envir = seen)
      ri <- ri + 1L
      result[[ri]] <- cls
    }
  }
  result[seq_len(ri)]
}

# -- print -----------------------------------------------------------

method(print, Atom) <- function(x, ...) {
  cat(sprintf("%s\n", expr_name(x)))
  invisible(x)
}