R/120_zzz_R_specific_operators.R

In CVXR: Disciplined Convex Optimization

#####
## DO NOT EDIT THIS FILE!! EDIT THE SOURCE INSTEAD: rsrc_tree/zzz_R_specific/operators.R
#####

## CVXPY SOURCE: (R-specific, no direct CVXPY equivalent)
## Operator dispatch for CVXR expressions
##
## R's operator dispatch differs from Python's __add__/__radd__ etc.
## We use two mechanisms:
##   1. S3 Ops group handler for +, -, *, / (handles both unary and binary)
##   2. S7 method() for %*% (not part of Ops group)
##
## Why S3 Ops instead of S7 method() for arithmetic:
##   S7 `method("-", list(Expression, class_any))` creates `-.CVXR::Expression`
##   which takes precedence over `Ops.CVXR::Expression` for BOTH unary and
##   binary `-`. The S7 method would fail for unary because e2 is missing.
##   Using S3 Ops handler for all arithmetic avoids this limitation.


# -- S3 Ops group handler --------------------------------------------
# Handles +, -, *, / for Expression objects (both unary and binary).
# Registered via registerS3method() in .onLoad().

.cvxr_Ops_handler <- function(e1, e2) {
  ## Unary operations: -x, +x, !x
  if (missing(e2)) {
    switch(.Generic,
      "-" = return(NegExpression(e1)),
      "+" = return(e1),
      "!" = return(Not(e1)),
      cli_abort("Unary {.val {(.Generic)}} not defined for CVXR expressions.")
    )
  }

  ## Binary: coerce non-Expression operands to Constant
  e1 <- as_expr(e1)
  e2 <- as_expr(e2)
  switch(.Generic,
    ## Arithmetic
    "+"  = { bcast <- broadcast_args(e1, e2); AddExpression(list(bcast[[1L]], bcast[[2L]])) },
    "-"  = { bcast <- broadcast_args(e1, NegExpression(e2)); AddExpression(list(bcast[[1L]], bcast[[2L]])) },
    "*"  = Multiply(e1, e2),
    "/"  = DivExpression(e1, e2),
    "^"  = power(e1, e2),
    ## Comparison -> Constraint objects
    "==" = Equality(e1, e2),
    "<=" = Inequality(e1, e2),         # lhs <= rhs
    ">=" = Inequality(e2, e1),         # lhs >= rhs  ==>  rhs <= lhs
    ## Boolean logic
    "&"  = And(e1, e2),
    "|"  = Or(e1, e2),
    cli_abort("Operator {.val {(.Generic)}} not yet implemented for CVXR expressions.")
  )
}

# -- chooseOpsMethod -------------------------------------------------
# When both operands have Ops methods (e.g., Matrix + Expression),
# this ensures CVXR's handler wins.  Requires R >= 4.3.

.cvxr_chooseOpsMethod <- function(x, y, mx, my, cl, reverse) TRUE

# -- %*% dispatch via S7 --------------------------------------------
# %*% is NOT in the Ops group; S7 method() works directly.

method(`%*%`, list(Expression, class_any)) <- function(x, y) {
  MulExpression(x, as_expr(y))
}

method(`%*%`, list(class_any, Expression)) <- function(x, y) {
  MulExpression(as_expr(x), y)
}

## Resolve ambiguity when both operands are Expressions
method(`%*%`, list(Expression, Expression)) <- function(x, y) {
  MulExpression(x, y)
}

# -- [ indexing via S7 ------------------------------------------------
# S7 method for `[` on Expression objects.
# Handles:
#   x[i, j]  -- both row and column specified
#   x[i, ]   -- row only (j is missing -> all columns)
#   x[, j]   -- column only (i is missing -> all rows)
#   x[i]     -- single index for vectors; for matrices, selects rows

method(`[`, Expression) <- function(x, i, j, ..., drop = FALSE) {
  ## Build key: list(row_indices, col_indices)
  ## NULL means "all" for that dimension
  if (missing(i) && missing(j)) {
    ## x[] -- return as-is
    return(x)
  }
  ## Determine nargs: were we called as x[i] or x[i, j]?
  ## R passes nargs() but we detect via sys.call
  cl <- sys.call()
  has_comma <- length(cl) > 3L || (!missing(j))
  ## Alternative detection: if called as x[i], j won't be in the call at all
  ## We check nargs() to distinguish x[i] from x[i,]
  if (!has_comma && !missing(i) && missing(j)) {
    ## x[i] -- single subscript
    ## For column vectors (n, 1): select rows
    ## For row vectors (1, m): select columns
    ## For matrices: flatten column-major and select
    if (x@shape[2L] == 1L) {
      key <- list(i, NULL)
    } else if (x@shape[1L] == 1L) {
      key <- list(NULL, i)
    } else {
      ## Matrix with single index: not supported for now (like CVXPY)
      cli_abort("Single-index selection on matrices not supported. Use {.code x[i, j]}.")
    }
  } else {
    ## x[i, j] or x[i, ] or x[, j]
    key <- list(
      if (missing(i)) NULL else i,
      if (missing(j)) NULL else j
    )
  }
  Index(x, key)
}

# -- S3 Math group handler -----------------------------------------
# Dispatches base R Math generics (abs, exp, log, sqrt, etc.) to CVXR atoms.
# Registered via registerS3method() in .onLoad().
# NOTE: H1 -- cumsum, cummax, cumprod, cummin are Math group, NOT Summary
# NOTE: H2 -- sign() conflicts with base::sign, must abort
# NOTE: H3 -- log2, log10, log1p routed through Log atom

.cvxr_Math_handler <- function(x, ...) {
  switch(.Generic,
    "abs"     = Abs(x),
    "exp"     = Exp(x),
    "log"     = Log(x),
    "sqrt"    = Power(x, 0.5),
    "cumsum"  = Cumsum(x),
    "sign"    = cli_abort(paste0(
                  "{.fn sign} is not supported for CVXR expressions. ",
                  "Use {.fn expr_sign} for DCP sign queries.")),
    "log2"    = DivExpression(Log(x), Constant(log(2))),
    "log10"   = DivExpression(Log(x), Constant(log(10))),
    "log1p"   = Log(AddExpression(list(x, Constant(1)))),
    "cummax"  = Cummax(x),
    "cumprod" = Cumprod(x),
    "ceiling"  = Ceil(x),
    "floor"    = Floor(x),
    "cummin"  = cli_abort("{.fn cummin} is not yet supported for CVXR expressions."),
    cli_abort("{.fn {(.Generic)}} is not supported for CVXR expressions.")
  )
}

# -- S3 Summary group handler -------------------------------------
# Dispatches base R Summary generics (sum, max, min, etc.) to CVXR atoms.
# Registered via registerS3method() in .onLoad().

.cvxr_Summary_handler <- function(..., na.rm = FALSE) {
  args <- list(...)
  x <- args[[1L]]
  switch(.Generic,
    "sum"   = {
      if (length(args) == 1L) {
        SumEntries(x)
      } else {
        ## sum(x, y, ...) -> SumEntries of addition
        result <- as_expr(args[[1L]])
        for (i in seq_along(args)[-1L]) {
          ai <- as_expr(args[[i]])
          bcast <- broadcast_args(result, ai)
          result <- AddExpression(list(bcast[[1L]], bcast[[2L]]))
        }
        SumEntries(result)
      }
    },
    "max"   = {
      if (length(args) == 1L) {
        MaxEntries(x)
      } else {
        ## max(x, y, ...) -> nested MaxEntries of add? No: max of multiple -> max_elemwise
        ## Actually, base::max(x, y) finds the max across all values, so
        ## we should construct MaxEntries of the concatenated expression.
        ## For simplicity with Expression objects, use pairwise max_elemwise
        result <- as_expr(args[[1L]])
        for (i in seq_along(args)[-1L]) {
          result <- Maximum(result, as_expr(args[[i]]))
        }
        result
      }
    },
    "min"   = {
      if (length(args) == 1L) {
        MinEntries(x)
      } else {
        result <- as_expr(args[[1L]])
        for (i in seq_along(args)[-1L]) {
          result <- Minimum(result, as_expr(args[[i]]))
        }
        result
      }
    },
    "prod"  = {
      if (length(args) == 1L) {
        Prod(x)
      } else {
        result <- as_expr(args[[1L]])
        for (i in seq_along(args)[-1L]) {
          result <- result * as_expr(args[[i]])
        }
        Prod(result)
      }
    },
    "range" = cli_abort("{.fn range} is not supported for CVXR expressions."),
    "any"   = cli_abort("{.fn any} is not applicable to CVXR expressions."),
    "all"   = cli_abort("{.fn all} is not applicable to CVXR expressions."),
    cli_abort("{.fn {(.Generic)}} is not supported for CVXR expressions.")
  )
}

# -- S3 Complex group handler -----------------------------------------
## Dispatches Re(), Im(), Conj() to CVXR atom constructors.
## R's Complex group generic includes: Arg, Conj, Im, Mod, Re.
## We support the three that map to CVXPY atoms.

.cvxr_Complex_handler <- function(z) {
  switch(.Generic,
    "Re"   = Real_(z),
    "Im"   = Imag_(z),
    "Conj" = Conj_(z),
    "Mod"  = Abs(z),
    "Arg"  = cli_abort("{.fn Arg} is not supported for CVXR expressions."),
    cli_abort("{.fn {(.Generic)}} is not supported for CVXR expressions.")
  )
}

# -- t() via S7 -------------------------------------------------------

method(t, Expression) <- function(x) {
  Transpose(x)
}

# -- mean() dispatch via S3 generic (base::mean is UseMethod) -----
# mean(expr, axis=1, keepdims=TRUE) works via ...
method(mean, Expression) <- function(x, ...) {
  cvxr_mean(x, ...)
}