S3 Group Generics and Operator Overloading

# A toy class: a count of items.
count <- function(n) structure(as.integer(n), class = "count")

Ops.count <- function(e1, e2) {
  generic <- .Generic # nolint: object_usage_linter.
  method <- .Method # nolint: object_usage_linter.
  group <- .Group # nolint: object_usage_linter.
  cat("group method for", generic, "\n")
  cat(".Method:", paste0("\"", method, "\""), "\n")
  cat(".Group: ", group, "\n")
  cat("nargs:  ", nargs(), "\n")
  invisible(NULL)
}

x <- count(1:3)
invisible(x + 1L)
#> group method for +
#> .Method: "Ops.count" ""
#> .Group:  Ops
#> nargs:   2
invisible(2L * x)
#> group method for *
#> .Method: "" "Ops.count"
#> .Group:  Ops
#> nargs:   2
invisible(x == x)
#> group method for ==
#> .Method: "Ops.count" "Ops.count"
#> .Group:  Ops
#> nargs:   2
invisible(-x)
#> group method for -
#> .Method: "Ops.count"
#> .Group:  Ops
#> nargs:   1

# Math and Summary methods see .Generic too.
Math.count <- function(x, ...) {
  generic <- .Generic # nolint: object_usage_linter.
  cat("Math method for", generic, "with", ...length(), "extra argument(s)\n")
  NextMethod()
}
Summary.count <- function(..., na.rm = FALSE) { # nolint: object_name_linter.
  generic <- .Generic # nolint: object_usage_linter.
  cat("Summary method for", generic, "- na.rm is", na.rm, "\n")
  NextMethod()
}
unclass(round(x, 1))
#> Math method for round with 1 extra argument(s)
#> [1] 1 2 3
unclass(cumsum(x))
#> Math method for cumsum with 0 extra argument(s)
#> [1] 1 3 6
max(x, na.rm = TRUE)
#> Summary method for max - na.rm is TRUE
#> [1] 3
range(x)
#> Summary method for range - na.rm is FALSE
#> [1] 1 3
# Repeating na.rm is an error (R 4.4.0 and later).
tryCatch(
  sum(1:3, na.rm = TRUE, na.rm = FALSE),
  error = \(e) conditionMessage(e)
)
#> [1] "formal argument \"na.rm\" matched by multiple actual arguments"

# A switch() arm without a value falls through to the next one; a trailing
# comma before the unnamed default makes that default ambiguous.
tryCatch(switch("a", a = , 1, 2), error = \(e) conditionMessage(e))
#> [1] "duplicate 'switch' defaults: '1' and '2'"

# Calling the operator on the original objects dispatches to the method again.
Ops.loop <- function(e1, e2) {
  generic <- .Generic # nolint: object_usage_linter.
  get(generic)(e1, e2)
}
op <- options(expressions = 200)
tryCatch(structure(1, class = "loop") + 1, error = \(e) conditionMessage(e))
#> [1] "evaluation nested too deeply: infinite recursion / options(expressions=)?"
options(op)

# The three ways of reaching the default behaviour from inside a method.
Ops.celsius <- function(e1, e2) {
  generic <- .Generic # nolint: object_usage_linter.
  by_get <- get(generic)(unclass(e1), unclass(e2))
  by_docall <- do.call(generic, list(unclass(e1), unclass(e2)))
  by_next <- unclass(NextMethod())
  list(by_get = by_get, by_docall = by_docall, by_next = by_next)
}
str(structure(c(10, 20), class = "celsius") + 1)
#> List of 3
#>  $ by_get   : num [1:2] 11 21
#>  $ by_docall: num [1:2] 11 21
#>  $ by_next  : num [1:2] 11 21

# One group method, one specific method.
temp <- function(x) structure(as.double(x), class = "temp")

Ops.temp <- function(e1, e2) {
  generic <- .Generic # nolint: object_usage_linter.
  cat("  Ops.temp handles", generic, "\n")
  get(generic)(unclass(e1), unclass(e2))
}
`*.temp` <- function(e1, e2) {
  cat("  *.temp handles *\n")
  temp(unclass(e1) * unclass(e2))
}

a <- temp(20)
b <- temp(2.5)
cat("a * b\n")
#> a * b
unclass(a * b)
#>   *.temp handles *
#> [1] 50
cat("a - b\n")
#> a - b
unclass(a - b)
#>   Ops.temp handles -
#> [1] 17.5
cat("a > b\n")
#> a > b
a > b
#>   Ops.temp handles >
#> [1] TRUE

# The class vector is searched from left to right; within one class the
# specific method comes before the group method.
x <- structure(1, class = c("first", "second"))
`*.second` <- function(e1, e2) "the specific method of second"
Ops.first <- function(e1, e2) "the group method of first"
x * 2
#> [1] "the group method of first"
`*.first` <- function(e1, e2) "the specific method of first"
x * 2
#> [1] "the specific method of first"

# NextMethod() from a specific method goes straight to the internal code.
`-.temp` <- function(e1, e2) {
  cat("  -.temp calls NextMethod()\n")
  NextMethod()
}
r <- a - b
#>   -.temp calls NextMethod()
cat("class of the result:", class(r), "\n")
#> class of the result: temp
unclass(r)
#> [1] 17.5

# A method for one member does not create a method for the group.
`*.money_like` <- function(e1, e2) "multiplied"
m <- structure(2, class = "money_like")
m * 3
#> [1] "multiplied"
unclass(m + 3)
#> [1] 5

# Group methods dispatch on the class attribute only, not on the implicit class.
Ops.integer <- function(e1, e2) "a method for integer"
1L + 1L
#> [1] 2

source("scenario.R")

# Part 1: constructor, helper, accessors, format and print.
new_money <- function(amount = double(), currency = "EUR") {
  stopifnot(is.double(amount), is.character(currency))
  structure(amount, currency = currency, class = "money")
}

money <- function(amount = double(), currency = "EUR") {
  if (!is.character(currency) || length(currency) != 1L ||
        !grepl("^[A-Z]{3}$", currency)) {
    stop("currency must be a three-letter code such as \"EUR\"",
         call. = FALSE)
  }
  new_money(as.double(amount), currency)
}

currency <- function(x) attr(x, "currency", exact = TRUE)
amount <- function(x) as.vector(unclass(x))

format.money <- function(x, digits = NULL, ...) {
  digits <- digits %||% 2L
  out <- paste(
    formatC(amount(x), format = "f", digits = digits, big.mark = ","),
    currency(x)
  )
  out[is.na(amount(x))] <- NA_character_
  names(out) <- names(x)
  out
}

print.money <- function(x, ...) {
  print(format(x), quote = FALSE, right = TRUE, ...)
  invisible(x)
}

fees <- money(c(0.25, 1.5, 12, 1234.5))
fees
#> [1]     0.25 EUR     1.50 EUR    12.00 EUR 1,234.50 EUR
class(fees)
#> [1] "money"
unclass(fees)
#> [1]    0.25    1.50   12.00 1234.50
#> attr(,"currency")
#> [1] "EUR"
tryCatch(money(5, "euros"), error = \(e) conditionMessage(e))
#> [1] "currency must be a three-letter code such as \"EUR\""

# Part 2: keep the attribute when subsetting and combining.
`[.money` <- function(x, ...) new_money(NextMethod(), currency(x))
`[[.money` <- function(x, ...) new_money(NextMethod(), currency(x))
`[<-.money` <- function(x, ..., value) {
  if (!inherits(value, "money") || !identical(currency(value), currency(x))) {
    stop("can only store ", currency(x), " amounts in a ", currency(x),
         " vector", call. = FALSE)
  }
  new_money(NextMethod(), currency(x))
}
c.money <- function(..., recursive = FALSE,
                    use.names = TRUE) { # nolint: object_name_linter.
  parts <- list(...)
  cur <- unique(vapply(parts, currency, character(1)))
  if (length(cur) != 1L) {
    stop("cannot combine ", paste(cur, collapse = " and "), call. = FALSE)
  }
  new_money(unlist(lapply(parts, amount)), cur)
}
rep.money <- function(x, ...) new_money(NextMethod(), currency(x))
unique.money <- function(x, ...) new_money(NextMethod(), currency(x))

fees[2:3]
#> [1]  1.50 EUR 12.00 EUR
fees[[4]]
#> [1] 1,234.50 EUR
rev(fees)
#> [1] 1,234.50 EUR    12.00 EUR     1.50 EUR     0.25 EUR
fees[-1]
#> [1]     1.50 EUR    12.00 EUR 1,234.50 EUR
x <- fees
x[2] <- money(2)
x
#> [1]     0.25 EUR     2.00 EUR    12.00 EUR 1,234.50 EUR
tryCatch({
  x[1] <- money(1, "USD")
}, error = \(e) conditionMessage(e))
#> [1] "can only store EUR amounts in a EUR vector"
tryCatch({
  x[1] <- 1
}, error = \(e) conditionMessage(e))
#> [1] "can only store EUR amounts in a EUR vector"
c(fees, money(0.75))
#> [1]     0.25 EUR     1.50 EUR    12.00 EUR 1,234.50 EUR     0.75 EUR
tryCatch(c(fees, money(1, "USD")), error = \(e) conditionMessage(e))
#> [1] "cannot combine EUR and USD"
rep(fees[1:2], times = 2)
#> [1] 0.25 EUR 1.50 EUR 0.25 EUR 1.50 EUR
unique(c(fees, fees))
#> [1]     0.25 EUR     1.50 EUR    12.00 EUR 1,234.50 EUR
length(fees)
#> [1] 4
sort(fees, decreasing = TRUE)
#> [1] 1,234.50 EUR    12.00 EUR     1.50 EUR     0.25 EUR
order(fees)
#> [1] 1 2 3 4

# Part 3: the Ops group.
same_currency <- function(e1, e2, verb) {
  if (!identical(currency(e1), currency(e2))) {
    stop("cannot ", verb, " ", currency(e1), " and ", currency(e2),
         call. = FALSE)
  }
}

Ops.money <- function(e1, e2) {
  generic <- .Generic # nolint: object_usage_linter.
  if (nargs() == 1L) {
    if (generic %in% c("+", "-")) {
      return(new_money(get(generic)(amount(e1)), currency(e1)))
    }
    stop("unary ", generic, " is not meaningful for money", call. = FALSE)
  }
  both <- inherits(e1, "money") && inherits(e2, "money")
  switch(generic,
    "+" = , "-" = {
      if (!both) stop("both operands must be money", call. = FALSE)
      same_currency(e1, e2, c("+" = "add", "-" = "subtract")[[generic]])
      new_money(get(generic)(amount(e1), amount(e2)), currency(e1))
    },
    "*" = {
      if (both) stop("cannot multiply money by money", call. = FALSE)
      cur <- currency(if (inherits(e1, "money")) e1 else e2)
      new_money(amount(e1) * amount(e2), cur)
    },
    "/" = {
      if (both) {
        same_currency(e1, e2, "divide")
        amount(e1) / amount(e2)
      } else if (inherits(e1, "money")) {
        new_money(amount(e1) / amount(e2), currency(e1))
      } else {
        stop("cannot divide a number by money", call. = FALSE)
      }
    },
    "==" = , "!=" = , "<" = , ">" = , "<=" = , ">=" = {
      if (!both) stop("can only compare money with money", call. = FALSE)
      same_currency(e1, e2, "compare")
      get(generic)(amount(e1), amount(e2))
    },
    stop(sQuote(generic), " is not meaningful for money", call. = FALSE)
  )
}

fees + fees
#> [1]     0.50 EUR     3.00 EUR    24.00 EUR 2,469.00 EUR
fees - money(0.25)
#> [1]     0.00 EUR     1.25 EUR    11.75 EUR 1,234.25 EUR
fees * 2
#> [1]     0.50 EUR     3.00 EUR    24.00 EUR 2,469.00 EUR
3 * fees
#> [1]     0.75 EUR     4.50 EUR    36.00 EUR 3,703.50 EUR
fees / 4
#> [1]   0.06 EUR   0.38 EUR   3.00 EUR 308.62 EUR
fees[4] / fees[1]
#> [1] 4938
-fees[1:2]
#> [1] -0.25 EUR -1.50 EUR
fees > money(1)
#> [1] FALSE  TRUE  TRUE  TRUE
fees == money(1.5)
#> [1] FALSE  TRUE FALSE FALSE
tryCatch(fees + money(1, "USD"), error = \(e) conditionMessage(e))
#> [1] "cannot add EUR and USD"
tryCatch(fees + 1, error = \(e) conditionMessage(e))
#> [1] "both operands must be money"
tryCatch(fees * fees, error = \(e) conditionMessage(e))
#> [1] "cannot multiply money by money"
tryCatch(fees * "a", error = \(e) conditionMessage(e))
#> [1] "non-numeric argument to binary operator"
tryCatch(fees < money(1, "USD"), error = \(e) conditionMessage(e))
#> [1] "cannot compare EUR and USD"
tryCatch(fees & fees, error = \(e) conditionMessage(e))
#> [1] "‘&’ is not meaningful for money"
tryCatch(!fees, error = \(e) conditionMessage(e))
#> [1] "unary ! is not meaningful for money"

# Part 4: the Math group.
Math.money <- function(x, ...) {
  generic <- .Generic # nolint: object_usage_linter.
  switch(generic,
    abs = , floor = , ceiling = , trunc = , round = , signif = , cumsum =
      new_money(get(generic)(amount(x), ...), currency(x)),
    sign = sign(amount(x)),
    stop(generic, "() is not meaningful for money", call. = FALSE)
  )
}

third <- money(10) / 3
third
#> [1] 3.33 EUR
round(third, 2)
#> [1] 3.33 EUR
round(third, 2) * 3
#> [1] 9.99 EUR
floor(fees)
#> [1]     0.00 EUR     1.00 EUR    12.00 EUR 1,234.00 EUR
abs(money(-2.5))
#> [1] 2.50 EUR
cumsum(fees)
#> [1]     0.25 EUR     1.75 EUR    13.75 EUR 1,248.25 EUR
sign(money(c(-2, 0, 3)))
#> [1] -1  0  1
tryCatch(sqrt(fees), error = \(e) conditionMessage(e))
#> [1] "sqrt() is not meaningful for money"
tryCatch(exp(fees), error = \(e) conditionMessage(e))
#> [1] "exp() is not meaningful for money"

# Part 5: the Summary group.
Summary.money <- function(..., na.rm = FALSE) { # nolint: object_name_linter.
  generic <- .Generic # nolint: object_usage_linter.
  if (!generic %in% c("sum", "min", "max", "range")) {
    stop(generic, "() is not meaningful for money", call. = FALSE)
  }
  parts <- list(...)
  if (!all(vapply(parts, inherits, logical(1), what = "money"))) {
    stop("all arguments must be money", call. = FALSE)
  }
  cur <- unique(vapply(parts, currency, character(1)))
  if (length(cur) != 1L) {
    stop("cannot combine ", paste(cur, collapse = " and "), call. = FALSE)
  }
  new_money(NextMethod(), cur)
}

sum(fees)
#> [1] 1,248.25 EUR
min(fees)
#> [1] 0.25 EUR
max(fees)
#> [1] 1,234.50 EUR
range(fees)
#> [1]     0.25 EUR 1,234.50 EUR
sum(fees, money(100))
#> [1] 1,348.25 EUR
sum(money(c(1, NA, 3)))
#> [1] <NA>
sum(money(c(1, NA, 3)), na.rm = TRUE)
#> [1] 4.00 EUR
tryCatch(prod(fees), error = \(e) conditionMessage(e))
#> [1] "prod() is not meaningful for money"
tryCatch(any(fees), error = \(e) conditionMessage(e))
#> [1] "any() is not meaningful for money"
tryCatch(sum(fees, 1), error = \(e) conditionMessage(e))
#> [1] "all arguments must be money"
tryCatch(sum(fees, money(1, "USD")), error = \(e) conditionMessage(e))
#> [1] "cannot combine EUR and USD"

# A vector class with a "currency" attribute and NO methods at all.
bare <- structure(c(0.25, 1.5, 1.5, 12), currency = "EUR", class = "bare")

# What happens to the class and to the attribute in each call?
results <- list(
  "x[1:2]" = bare[1:2],
  "x[[1]]" = bare[[1]],
  "rev(x)" = rev(bare),
  "rep(x, 2)" = rep(bare, 2),
  "c(x, x)" = c(bare, bare),
  "unique(x)" = unique(bare),
  "sort(x)" = sort(bare),
  "mean(x)" = mean(bare),
  "median(x)" = median(bare),
  "diff(x)" = diff(bare),
  "seq(x[1], x[4], length.out = 3)" = seq(bare[1], bare[4], length.out = 3),
  "as.character(x)" = as.character(bare),
  "as.double(x)" = as.double(bare),
  "x + 1" = bare + 1,
  "x * 2" = bare * 2,
  "x > 1" = bare > 1,
  "round(x)" = round(bare),
  "sqrt(x)" = sqrt(bare),
  "cumsum(x)" = cumsum(bare),
  "sum(x)" = sum(bare),
  "max(x)" = max(bare),
  "range(x)" = range(bare)
)
group <- c(
  "x + 1" = "Ops", "x * 2" = "Ops", "x > 1" = "Ops",
  "round(x)" = "Math", "sqrt(x)" = "Math", "cumsum(x)" = "Math",
  "sum(x)" = "Summary", "max(x)" = "Summary", "range(x)" = "Summary"
)
survey <- data.frame(
  call = names(results),
  group = ifelse(is.na(group[names(results)]), "-", group[names(results)]),
  class = vapply(results, \(r) class(r)[[1L]], character(1)),
  currency = vapply(
    results, \(r) if (is.null(attr(r, "currency"))) "lost" else "kept",
    character(1)
  ),
  row.names = NULL
)
print(survey, right = FALSE)
#>    call                            group   class     currency
#> 1  x[1:2]                          -       numeric   lost
#> 2  x[[1]]                          -       numeric   lost
#> 3  rev(x)                          -       numeric   lost
#> 4  rep(x, 2)                       -       numeric   lost
#> 5  c(x, x)                         -       numeric   lost
#> 6  unique(x)                       -       numeric   lost
#> 7  sort(x)                         -       numeric   lost
#> 8  mean(x)                         -       numeric   lost
#> 9  median(x)                       -       numeric   lost
#> 10 diff(x)                         -       bare      lost
#> 11 seq(x[1], x[4], length.out = 3) -       numeric   lost
#> 12 as.character(x)                 -       character lost
#> 13 as.double(x)                    -       numeric   lost
#> 14 x + 1                           Ops     bare      kept
#> 15 x * 2                           Ops     bare      kept
#> 16 x > 1                           Ops     logical   lost
#> 17 round(x)                        Math    bare      kept
#> 18 sqrt(x)                         Math    bare      kept
#> 19 cumsum(x)                       Math    numeric   lost
#> 20 sum(x)                          Summary numeric   lost
#> 21 max(x)                          Summary numeric   lost
#> 22 range(x)                        Summary numeric   lost

# Part 6: generics that are not in a group need methods of their own.
tryCatch(fees$currency, error = \(e) conditionMessage(e))
#> [1] "$ operator is invalid for atomic vectors"

mean.money <- function(x, ...) new_money(mean(amount(x), ...), currency(x))
median.money <- function(x, na.rm = FALSE, ...) { # nolint: object_name_linter.
  new_money(median(amount(x), na.rm = na.rm), currency(x))
}
seq.money <- function(from, to, by, ...) {
  new_money(seq(amount(from), amount(to), by = amount(by), ...), currency(from))
}
as.character.money <- function(x, ...) format(x, ...)
as.double.money <- function(x, ...) amount(x)
`$.money` <- function(x, name) {
  switch(name,
    currency = currency(x),
    amount = amount(x),
    stop("money has no field ", sQuote(name), call. = FALSE)
  )
}

mean(fees)
#> [1] 312.06 EUR
median(fees)
#> [1] 6.75 EUR
seq(money(0), money(1), by = money(0.25))
#> [1] 0.00 EUR 0.25 EUR 0.50 EUR 0.75 EUR 1.00 EUR
as.character(fees[1:2])
#> [1] "0.25 EUR" "1.50 EUR"
paste("fee:", fees[1:2])
#> [1] "fee: 0.25 EUR" "fee: 1.50 EUR"
as.double(fees)
#> [1]    0.25    1.50   12.00 1234.50
fees$currency
#> [1] "EUR"
fees$amount
#> [1]    0.25    1.50   12.00 1234.50
tryCatch(fees$cost, error = \(e) conditionMessage(e))
#> [1] "money has no field ‘cost’"

# The condition of a library copy, stored as text but ordered by quality.
condition_levels <- c("poor", "fair", "good", "new")

copy_condition <- function(x = character()) {
  stopifnot(all(x %in% condition_levels))
  structure(x, class = "copy_condition")
}
`[.copy_condition` <- function(x, ...) copy_condition(NextMethod())
format.copy_condition <- function(x, ...) format(unclass(x), ...)
print.copy_condition <- function(x, ...) {
  print(format(x), quote = FALSE)
  invisible(x)
}

shelf <- copy_condition(c("good", "new", "poor", "fair", "good"))

# Without xtfrm() the default sorts the text alphabetically.
sort(shelf)
#> [1] fair good good new  poor
order(shelf)
#> [1] 4 1 5 2 3

# xtfrm() returns the sort keys; sort() and order() use it for any object.
xtfrm.copy_condition <- function(x) match(unclass(x), condition_levels)
xtfrm(shelf)
#> [1] 3 4 1 2 3
sort(shelf)
#> [1] poor fair good good new
sort(shelf, decreasing = TRUE)
#> [1] new  good good fair poor
order(shelf)
#> [1] 3 4 1 5 2

# A numeric class needs no method: the default returns the numbers.
getS3method("xtfrm", "default")(structure(c(3, 1, 2), class = "anything"))
#> [1] 3 1 2

# Part 7: late fees on the shelf, 0.25 EUR per day after the loan period.
end_date <- loans$return_date
end_date[is.na(end_date)] <- shelf_today
days_out <- as.integer(end_date - loans$loan_date)
days_late <- pmax(0L, days_out - loan_days)
late_fee <- money(0.25 * days_late)
loans$fee <- late_fee

head(loans[, c("loan_id", "loan_date", "fee")], 4)
#>   loan_id  loan_date      fee
#> 1    L001 2025-01-14 0.00 EUR
#> 2    L002 2025-01-16 0.00 EUR
#> 3    L003 2025-01-21 0.00 EUR
#> 4    L004 2025-01-26 1.25 EUR
fee_total <- sum(late_fee, na.rm = TRUE)
fee_total
#> [1] 111.75 EUR
max(late_fee, na.rm = TRUE)
#> [1] 15.75 EUR
mean(late_fee, na.rm = TRUE)
#> [1] 1.89 EUR
round(late_fee[1:6])
#> [1] 0.00 EUR 0.00 EUR 0.00 EUR 1.00 EUR 1.00 EUR 0.00 EUR
long_overdue <- loans[which(late_fee > money(10)), c("loan_id", "fee")]
head(long_overdue[order(long_overdue$fee, decreasing = TRUE), ], 4)
#>    loan_id       fee
#> 54    L054 15.75 EUR
#> 55    L055 15.00 EUR
#> 56    L056 12.50 EUR
#> 57    L057 11.00 EUR

member <- tolower(trimws(loans$member))
member[!nzchar(member)] <- NA
per_member <- vapply(
  split(late_fee, member),
  \(f) amount(sum(f, na.rm = TRUE)),
  numeric(1)
)
head(sort(new_money(per_member), decreasing = TRUE), 3)
#>    dev patel     ana ruiz chloe martin
#>    25.25 EUR    24.75 EUR    24.50 EUR

# Part 8: mixing money with a class that has its own method.
tryCatch(late_fee[1:3] + shelf_today, warning = \(w) conditionMessage(w))
#> [1] "Incompatible methods (\"Ops.money\", \"+.Date\") for \"+\""
suppressWarnings(late_fee[1:3] + shelf_today)
#> [1] 20,634.00 EUR 20,634.00 EUR 20,634.00 EUR

chooseOpsMethod.money <- function(x, y, mx, my, cl, reverse) TRUE
tryCatch(late_fee[1:3] + shelf_today, error = \(e) conditionMessage(e))
#> [1] "both operands must be money"
tryCatch(shelf_today + late_fee[1:3], error = \(e) conditionMessage(e))
#> [1] "both operands must be money"
tryCatch(late_fee[1:3] == shelf_today, error = \(e) conditionMessage(e))
#> [1] "can only compare money with money"
late_fee[1:3] + money(1)
#> [1] 1.00 EUR 1.00 EUR 1.00 EUR