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_S7 <- new_generic("foo_S7", "x")
method(foo_S7, 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", "S7_object"))
setOldClass(c("text", "character", "S7_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_S7(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_S7(x)    9.28µs  10.66µs    89403.    21.3KB     26.8
#> 2 foo_S3(x)    2.65µs   2.98µs   308473.        0B     30.9
#> 3 foo_S4(x)    2.86µs   3.23µs   292760.        0B     29.3

bar_S7 <- new_generic("bar_S7", c("x", "y"))
method(bar_S7, 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_S7(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_S7(x, y)  16.36µs   18.2µs    52996.        0B     26.5
#> 2 bar_S4(x, y)   7.97µs   8.84µs   110038.        0B     11.0

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 hierarchy vs the time to dispatch on the last class.

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

library(S7)

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_S7 <- new_generic("foo_S7", "x")
    method(foo_S7, cls) <- function(x, ...) paste0(x, "-foo")

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

    bench::mark(
      best = foo_S7(x),
      worst = foo2_S7(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   9.42µs   10.7µs    91769.        0B     27.5
#>  2 worst                3          15   9.63µs   10.9µs    89520.        0B     26.9
#>  3 best                 5          15   9.45µs   10.8µs    90388.        0B     36.2
#>  4 worst                5          15   9.68µs     11µs    89181.        0B     26.8
#>  5 best                10          15   9.54µs   10.9µs    90062.        0B     27.0
#>  6 worst               10          15   9.96µs   11.2µs    86829.        0B     34.7
#>  7 best                50          15  10.09µs   11.4µs    86064.        0B     34.4
#>  8 worst               50          15  11.81µs   13.1µs    75051.        0B     22.5
#>  9 best               100          15  10.73µs   12.1µs    79128.        0B     31.7
#> 10 worst              100          15  14.35µs   15.9µs    61591.        0B     24.6
#> 11 best                 3         100   9.27µs   10.7µs    91272.        0B     36.5
#> 12 worst                3         100   9.66µs   10.9µs    89197.        0B     26.8
#> 13 best                 5         100   9.47µs   10.7µs    90779.        0B     27.2
#> 14 worst                5         100   9.76µs   11.1µs    87613.        0B     35.1
#> 15 best                10         100   9.59µs   10.9µs    87915.        0B     26.4
#> 16 worst               10         100  10.16µs   11.6µs    81614.        0B     24.5
#> 17 best                50         100   9.91µs   11.2µs    86860.        0B     26.1
#> 18 worst               50         100  14.89µs   16.3µs    60138.        0B     24.1
#> 19 best               100         100   10.8µs   12.1µs    80680.        0B     32.3
#> 20 worst              100         100   21.6µs   23.3µs    41700.        0B     16.7

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_S7 <- new_generic("foo_S7", c("x", "y"))
    method(foo_S7, list(cls, cls)) <- function(x, y, ...) paste0(x, y, "-foo")

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

    bench::mark(
      best = foo_S7(x, y),
      worst = foo2_S7(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   11.1µs   12.6µs    76933.        0B     38.5
#>  2 worst                3          15   11.6µs   13.2µs    73738.        0B     29.5
#>  3 best                 5          15     11µs   11.7µs    84378.        0B     33.8
#>  4 worst                5          15   11.4µs   12.1µs    81509.        0B     32.6
#>  5 best                10          15   11.1µs   11.9µs    83022.        0B     33.2
#>  6 worst               10          15   11.9µs   12.6µs    78432.        0B     31.4
#>  7 best                50          15   12.1µs   12.9µs    76366.        0B     30.6
#>  8 worst               50          15   15.5µs   16.7µs    58936.        0B     23.6
#>  9 best               100          15   13.6µs   14.7µs    64310.        0B     32.2
#> 10 worst              100          15   20.4µs   21.5µs    45628.        0B     22.8
#> 11 best                 3         100   11.2µs   12.4µs    78347.        0B     31.4
#> 12 worst                3         100   12.1µs   13.4µs    72037.        0B     28.8
#> 13 best                 5         100   11.2µs   12.5µs    77468.        0B     31.0
#> 14 worst                5         100   12.4µs   13.8µs    69157.        0B     27.7
#> 15 best                10         100   11.3µs   12.7µs    75125.        0B     30.1
#> 16 worst               10         100   13.4µs   14.8µs    65397.        0B     26.2
#> 17 best                50         100   12.8µs     14µs    69414.        0B     27.8
#> 18 worst               50         100     22µs   23.3µs    42206.        0B     16.9
#> 19 best               100         100   13.8µs   15.2µs    64052.        0B     32.0
#> 20 worst              100         100   33.3µs   35.1µs    27933.        0B     11.2