R/036_atoms_affine_promote.R

In CVXR: Disciplined Convex Optimization

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

## CVXPY SOURCE: atoms/affine/promote.py
## Promote -- promote a scalar expression to a vector/matrix shape
##
## Also provides cvxr_promote() (the function) and broadcast_args() helper.


Promote <- new_class("Promote", parent = AffAtom, package = "CVXR",
  constructor = function(expr, shape) {
    expr <- as_expr(expr)
    shape <- validate_shape(shape)
    new_object(S7_object(),
      id    = next_expr_id(),
      .cache = new.env(parent = emptyenv()),
      args  = list(expr),
      shape = shape
    )
  }
)

# -- shape_from_args -------------------------------------------------
## CVXPY SOURCE: promote.py lines 86-89

method(shape_from_args, Promote) <- function(x) x@shape

# -- log-log curvature: affine (CVXPY promote.py lines 52-56) ---------
method(is_atom_log_log_convex, Promote) <- function(x) TRUE
method(is_atom_log_log_concave, Promote) <- function(x) TRUE

# -- get_data: returns promoted shape for reconstruction -------------
## CVXPY SOURCE: promote.py lines 91-94

method(get_data, Promote) <- function(x) list(x@shape)

# -- numeric_value ---------------------------------------------------
## CVXPY SOURCE: promote.py lines 67-71 (numpy_numeric wrapper)

method(numeric_value, Promote) <- function(x, values, ...) {
  matrix(as.vector(values[[1L]]), nrow = x@shape[1L], ncol = x@shape[2L])
}

# -- is_symmetric ----------------------------------------------------
## CVXPY SOURCE: promote.py lines 73-76

method(is_symmetric, Promote) <- function(x) {
  length(x@shape) == 2L && x@shape[1L] == x@shape[2L]
}

# -- graph_implementation --------------------------------------------
## CVXPY SOURCE: promote.py lines 96-115

method(graph_implementation, Promote) <- function(x, arg_objs, shape, data = NULL, ...) {
  list(promote_linop(arg_objs[[1L]], shape), list())
}

# -- expr_name: suppress shape data in display -------------------------
method(expr_name, Promote) <- function(x) {
  expr_name(x@args[[1L]])
}

# -- cvxr_promote: function to conditionally promote -----------------
## CVXPY SOURCE: promote.py lines 27-49 (promote function)

#' Promote a scalar expression to the given shape
#' @param expr An expression
#' @param shape Target shape
#' @returns The expression (unchanged if already the right shape) or a Promote atom
#' @keywords internal
cvxr_promote <- function(expr, shape) {
  expr <- as_expr(expr)
  shape <- validate_shape(shape)
  if (!identical(expr@shape, shape)) {
    if (!expr_is_scalar(expr)) {
      cli_abort("Only scalars may be promoted.")
    }
    Promote(expr, shape)
  } else {
    expr
  }
}

# -- broadcast_args: broadcast expressions for binary ops ------------
## CVXPY SOURCE: expressions/expression.py lines 658-690 (Expression.broadcast)
## Scalar promotion + full 2D broadcasting via ones-matrix multiplication.
## Called from +, -, *, / operators before atom construction.

#' Broadcast two expressions for binary operations
#' @param lh_expr Left-hand expression
#' @param rh_expr Right-hand expression
#' @returns List of two expressions with compatible shapes
#' @keywords internal
broadcast_args <- function(lh_expr, rh_expr) {
  ## Fast path: shapes already match (the common case)
  if (identical(lh_expr@shape, rh_expr@shape)) return(list(lh_expr, rh_expr))

  lh_expr <- as_expr(lh_expr)
  rh_expr <- as_expr(rh_expr)

  ## Promote scalars (CVXPY expression.py lines 663-669)
  if (expr_is_scalar(lh_expr) && !expr_is_scalar(rh_expr)) {
    lh_expr <- cvxr_promote(lh_expr, rh_expr@shape)
  } else if (expr_is_scalar(rh_expr) && !expr_is_scalar(lh_expr)) {
    rh_expr <- cvxr_promote(rh_expr, lh_expr@shape)
  } else if (expr_is_scalar(lh_expr) && expr_is_scalar(rh_expr)) {
    return(list(lh_expr, rh_expr))
  }

  ## Full 2D broadcasting (CVXPY expression.py lines 671-682)
  ## Expand dimension-1 axes via matrix multiplication with ones vectors,
  ## e.g. (1,n) -> (m,n) via ones(m,1) %*% expr
  if (length(lh_expr@shape) == 2L && length(rh_expr@shape) == 2L) {
    dims <- pmax(lh_expr@shape, rh_expr@shape)
    ## Broadcast along dim 1 (rows)
    if (lh_expr@shape[1L] == 1L && lh_expr@shape[1L] < dims[1L]) {
      lh_expr <- Constant(matrix(1, dims[1L], 1L)) %*% lh_expr
    }
    if (rh_expr@shape[1L] == 1L && rh_expr@shape[1L] < dims[1L]) {
      rh_expr <- Constant(matrix(1, dims[1L], 1L)) %*% rh_expr
    }
    ## Broadcast along dim 2 (cols)
    if (lh_expr@shape[2L] == 1L && lh_expr@shape[2L] < dims[2L]) {
      lh_expr <- lh_expr %*% Constant(matrix(1, 1L, dims[2L]))
    }
    if (rh_expr@shape[2L] == 1L && rh_expr@shape[2L] < dims[2L]) {
      rh_expr <- rh_expr %*% Constant(matrix(1, 1L, dims[2L]))
    }
  }
  list(lh_expr, rh_expr)
}