Multiple dispatch in R without S4

multi_dispatch.R

# ---- Multiple dispatch functions -----
multi_dispatch <- function(gen_name) {
  calling_env <- parent.frame()
  parent_call <- sys.call(sys.parent())
  calling_fun <- sys.function(sys.parent())

  arg1 <- eval(parent_call[[2]], calling_env)
  arg2 <- eval(parent_call[[3]], calling_env)

  class_combos <- expand.grid(class(arg1), class(arg2))
  search_methods <- paste(class_combos[[1]], class_combos[[2]], sep = ".")

  # Grab all methods
  methods <- attr(calling_fun, "methods", exact = TRUE)
  # Find first item in search_methods which is in methods
  match_idx <- match(search_methods, ls(methods))
  if (all(is.na(match_idx))) {
    stop("No matching methods found for class combinations: ",
      paste(search_methods, collapse = ", "))
  }
  # Get first non-NA match
  first_match_idx <- min(which(!is.na(match_idx)))
  method_name <- search_methods[first_match_idx]
  fn <- methods[[method_name]]

  # Construct a call
  new_call <- parent_call
  new_call[[1]] <- fn
  eval(new_call, calling_env)
}


reg_multi_dispatch <- function(gen_name, class1, class2, fn, env = parent.frame()) {
  if (!is.function(env[[gen_name]]))
    stop("Generic function ", gen_name, " not found.")

  method_name <- paste(class1, class2, sep = ".")

  # Register the method in an environment, stored in an attribute of the generic
  methods_env <- attr(env[[gen_name]], "methods")
  if (is.null(methods_env)) {
    methods_env <- new.env(parent = emptyenv(), hash = FALSE)
    attr(env[[gen_name]], "methods") <- methods_env
  }
  methods_env[[method_name]] <- fn

  # Return the generic
  env[[gen_name]]
}


# ---- Create the generic + method ----
# Set up the generic
f <- function(x, y, ...) multi_dispatch("f")



# Register a method for A.B
reg_multi_dispatch("f", "A", "B", function(x, y, ...) {
  print(paste0("A.B called with x=", x, ", y=", y))
})

# Register a method for D.B
reg_multi_dispatch("f", "D", "B", function(x, y, ...) {
  print(paste0("D.B called with x=", x, ", y=", y))
})

# Register a method for D.C
reg_multi_dispatch("f", "D", "C", function(x, y, ...) {
  print(paste0("D.C called with x=", x, ", y=", y))
})



# ---- Test it out ----
A <- structure('objA', class = 'A')
B <- structure('objB', class = 'B')
BC <- structure('objBC', class = c('B', 'C'))
CB <- structure('objCB', class = c('C', 'B'))
D <- structure('objD', class = 'D')

f(A, B)
# [1] "A and B called with x=objA, y=objB"

f(B, A)
# Error in multi_dispatch("f") :
#  No matching methods found for class combinations: B.A

f(D, B)
# [1] "D.B called with x=objD, y=objB"
f(D, C)
# [1] "D.C called with x=objD, y=objC"

f(D, BC)
# [1] "D.B called with x=objD, y=objBC"
f(D, CB)
# [1] "D.C called with x=objD, y=objCB"