Skip to contents

The dispatch performance should be roughly on par with S3 and S4, though as this is implemented in a package there is some overhead due to .Call vs .Primitive.

text <- new_class("text", parent = class_character)
number <- new_class("number", parent = class_double)

x <- text("hi")
y <- number(1)

foo_R7 <- new_generic("foo_R7", "x")
method(foo_R7, text) <- function(x, ...) paste0(x, "-foo")

foo_S3 <- function(x, ...) {
  UseMethod("foo_S3")
}

foo_S3.text <- function(x, ...) {
  paste0(x, "-foo")
}

library(methods)
setOldClass(c("number", "numeric", "R7_object"))
setOldClass(c("text", "character", "R7_object"))

setGeneric("foo_S4", function(x, ...) standardGeneric("foo_S4"))
#> [1] "foo_S4"
setMethod("foo_S4", c("text"), function(x, ...) paste0(x, "-foo"))

# Measure performance of single dispatch
bench::mark(foo_R7(x), foo_S3(x), foo_S4(x))
#> # A tibble: 3 × 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 foo_R7(x)     7.7µs    9.2µs    87511.    16.6KB     26.3
#> 2 foo_S3(x)     2.6µs      3µs   295749.        0B     29.6
#> 3 foo_S4(x)       3µs    3.5µs   268225.        0B      0

bar_R7 <- new_generic("bar_R7", c("x", "y"))
method(bar_R7, list(text, number)) <- function(x, y, ...) paste0(x, "-", y, "-bar")

setGeneric("bar_S4", function(x, y, ...) standardGeneric("bar_S4"))
#> [1] "bar_S4"
setMethod("bar_S4", c("text", "number"), function(x, y, ...) paste0(x, "-", y, "-bar"))

# Measure performance of double dispatch
bench::mark(bar_R7(x, y), bar_S4(x, y))
#> # A tibble: 2 × 6
#>   expression        min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr>   <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 bar_R7(x, y)     14µs   16.4µs    59806.        0B     23.9
#> 2 bar_S4(x, y)    8.6µs    9.6µs   101302.        0B     20.3

A potential optimization is caching based on the class names, but lookup should be fast without this.

The following benchmark generates a class hierarchy of different levels and lengths of class names and compares the time to dispatch on the first class in the hiearchy vs the time to dispatch on the last class.

We find that even in very extreme cases (e.g. 100 deep heirachy 100 of character class names) the overhead is reasonable, and for more reasonable cases (e.g. 10 deep hiearchy of 15 character class names) the overhead is basically negligible.

library(R7)

gen_character <- function (n, min = 5, max = 25, values = c(letters, LETTERS, 0:9)) {
  lengths <- sample(min:max, replace = TRUE, size = n)
  values <- sample(values, sum(lengths), replace = TRUE)
  starts <- c(1, cumsum(lengths)[-n] + 1)
  ends <- cumsum(lengths)
  mapply(function(start, end) paste0(values[start:end], collapse=""), starts, ends)
}

bench::press(
  num_classes = c(3, 5, 10, 50, 100),
  class_nchar = c(15, 100),
  {
    # Construct a class hierarchy with that number of classes
    text <- new_class("text", parent = class_character)
    parent <- text
    classes <- gen_character(num_classes, min = class_nchar, max = class_nchar)
    env <- new.env()
    for (x in classes) {
      assign(x, new_class(x, parent = parent), env)
      parent <- get(x, env)
    }

    # Get the last defined class
    cls <- parent

    # Construct an object of that class
    x <- do.call(cls, list("hi"))

    # Define a generic and a method for the last class (best case scenario)
    foo_R7 <- new_generic("foo_R7", "x")
    method(foo_R7, cls) <- function(x, ...) paste0(x, "-foo")

    # Define a generic and a method for the first class (worst case scenario)
    foo2_R7 <- new_generic("foo2_R7", "x")
    method(foo2_R7, R7_object) <- function(x, ...) paste0(x, "-foo")

    bench::mark(
      best = foo_R7(x),
      worst = foo2_R7(x)
    )
  }
)
#> # A tibble: 20 × 8
#>    expression num_classes class_nchar      min   median `itr/sec` mem_alloc `gc/sec`
#>    <bch:expr>       <dbl>       <dbl> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#>  1 best                 3          15    7.7µs    9.2µs   105386.        0B     31.6
#>  2 worst                3          15    7.9µs    9.5µs   101859.        0B     30.6
#>  3 best                 5          15    7.8µs    9.3µs   104329.        0B     31.3
#>  4 worst                5          15      8µs    9.5µs   102637.        0B     30.8
#>  5 best                10          15    7.8µs    9.3µs   104506.        0B     31.4
#>  6 worst               10          15    8.4µs    9.9µs    98748.        0B     29.6
#>  7 best                50          15    8.4µs    9.9µs    97763.        0B     29.3
#>  8 worst               50          15   10.6µs   12.2µs    78985.        0B     23.7
#>  9 best               100          15    9.1µs   10.7µs    90487.        0B     36.2
#> 10 worst              100          15   13.4µs     15µs    65193.        0B     19.6
#> 11 best                 3         100    7.7µs    9.8µs    98940.        0B     29.7
#> 12 worst                3         100      8µs    9.6µs   100644.        0B     30.2
#> 13 best                 5         100    7.8µs    9.4µs   102925.        0B     30.9
#> 14 worst                5         100    8.3µs     10µs    96510.        0B     29.0
#> 15 best                10         100    7.9µs    9.5µs   101222.        0B     30.4
#> 16 worst               10         100    8.9µs   10.7µs    90199.        0B     27.1
#> 17 best                50         100    8.5µs     10µs    96349.        0B     28.9
#> 18 worst               50         100   14.2µs   15.8µs    61903.        0B     18.6
#> 19 best               100         100    9.1µs   10.8µs    89266.        0B     35.7
#> 20 worst              100         100     20µs   20.9µs    47005.        0B     14.1

And the same benchmark using double-dispatch

bench::press(
  num_classes = c(3, 5, 10, 50, 100),
  class_nchar = c(15, 100),
  {
    # Construct a class hierarchy with that number of classes
    text <- new_class("text", parent = class_character)
    parent <- text
    classes <- gen_character(num_classes, min = class_nchar, max = class_nchar)
    env <- new.env()
    for (x in classes) {
      assign(x, new_class(x, parent = parent), env)
      parent <- get(x, env)
    }

    # Get the last defined class
    cls <- parent

    # Construct an object of that class
    x <- do.call(cls, list("hi"))
    y <- do.call(cls, list("ho"))

    # Define a generic and a method for the last class (best case scenario)
    foo_R7 <- new_generic("foo_R7", c("x", "y"))
    method(foo_R7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo")

    # Define a generic and a method for the first class (worst case scenario)
    foo2_R7 <- new_generic("foo2_R7", c("x", "y"))
    method(foo2_R7, list(R7_object, R7_object)) <- function(x, y, ...) paste0(x, y, "-foo")

    bench::mark(
      best = foo_R7(x, y),
      worst = foo2_R7(x, y)
    )
  }
)
#> # A tibble: 20 × 8
#>    expression num_classes class_nchar      min   median `itr/sec` mem_alloc `gc/sec`
#>    <bch:expr>       <dbl>       <dbl> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#>  1 best                 3          15    9.3µs     10µs    97446.        0B    29.2 
#>  2 worst                3          15    9.7µs   10.3µs    94856.        0B    38.0 
#>  3 best                 5          15    9.4µs     10µs    98041.        0B    29.4 
#>  4 worst                5          15    9.9µs   10.6µs    90849.        0B    36.4 
#>  5 best                10          15    9.5µs   10.2µs    94776.        0B    37.9 
#>  6 worst               10          15   10.4µs   11.5µs    84249.        0B    25.3 
#>  7 best                50          15   10.8µs   11.8µs    82663.        0B    24.8 
#>  8 worst               50          15   14.8µs   15.7µs    62038.        0B    24.8 
#>  9 best               100          15   12.1µs   13.5µs    71805.        0B    28.7 
#> 10 worst              100          15   20.8µs   22.3µs    43499.        0B    17.4 
#> 11 best                 3         100    9.6µs     11µs    87102.        0B    34.9 
#> 12 worst                3         100   10.2µs   11.8µs    81208.        0B    32.5 
#> 13 best                 5         100    9.6µs   11.1µs    86432.        0B    34.6 
#> 14 worst                5         100   10.7µs   12.1µs    79529.        0B    31.8 
#> 15 best                10         100    9.8µs   11.2µs    85060.        0B    34.0 
#> 16 worst               10         100   12.2µs   13.6µs    70447.        0B    28.2 
#> 17 best                50         100   10.8µs   12.3µs    77614.        0B    31.1 
#> 18 worst               50         100   20.8µs   22.4µs    43632.        0B    17.5 
#> 19 best               100         100   12.4µs   13.5µs    70631.        0B    14.1 
#> 20 worst              100         100   34.5µs   35.8µs    27644.        0B     5.53