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.53µs 10.62µs 91326. 21.3KB 27.4
#> 2 foo_S3(x) 2.65µs 2.95µs 312500. 0B 31.3
#> 3 foo_S4(x) 2.85µs 3.25µs 289437. 0B 28.9
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) 15.48µs 17.06µs 57419. 0B 34.5
#> 2 bar_S4(x, y) 7.47µs 8.34µs 116485. 0B 23.3A 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.57µs 10.8µs 90656. 0B 36.3
#> 2 worst 3 15 9.65µs 10.8µs 91084. 0B 36.4
#> 3 best 5 15 9.39µs 10.6µs 89955. 0B 36.0
#> 4 worst 5 15 9.7µs 10.7µs 91774. 0B 36.7
#> 5 best 10 15 9.64µs 10.7µs 92330. 0B 36.9
#> 6 worst 10 15 9.96µs 11.1µs 88852. 0B 35.6
#> 7 best 50 15 10.22µs 11.4µs 86157. 0B 34.5
#> 8 worst 50 15 11.81µs 12.9µs 75917. 0B 30.4
#> 9 best 100 15 10.81µs 12.1µs 80546. 0B 40.3
#> 10 worst 100 15 14.55µs 15.8µs 62036. 0B 24.8
#> 11 best 3 100 9.35µs 10.6µs 91977. 0B 36.8
#> 12 worst 3 100 9.65µs 10.8µs 89793. 0B 35.9
#> 13 best 5 100 9.51µs 10.6µs 91664. 0B 36.7
#> 14 worst 5 100 10.02µs 11.1µs 87876. 0B 35.2
#> 15 best 10 100 9.56µs 10.6µs 89354. 0B 35.8
#> 16 worst 10 100 10.58µs 11.7µs 83218. 0B 33.3
#> 17 best 50 100 10.2µs 11.5µs 85222. 0B 34.1
#> 18 worst 50 100 15.54µs 16.8µs 58390. 0B 29.2
#> 19 best 100 100 10.63µs 11.7µs 78180. 0B 15.6
#> 20 worst 100 100 20.44µs 21.6µs 44937. 0B 8.99And 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.3µs 12.3µs 79666. 0B 23.9
#> 2 worst 3 15 11.6µs 12.6µs 78010. 0B 15.6
#> 3 best 5 15 10.8µs 11.9µs 81623. 0B 24.5
#> 4 worst 5 15 11.7µs 12.6µs 78138. 0B 23.4
#> 5 best 10 15 11.3µs 12.3µs 80127. 0B 24.0
#> 6 worst 10 15 12.1µs 13.1µs 74976. 0B 15.0
#> 7 best 50 15 12.3µs 13.4µs 73604. 0B 22.1
#> 8 worst 50 15 16.1µs 17.2µs 57354. 0B 17.2
#> 9 best 100 15 13.5µs 14.7µs 66621. 0B 20.0
#> 10 worst 100 15 20.7µs 21.9µs 45031. 0B 13.5
#> 11 best 3 100 11.3µs 12.4µs 79317. 0B 23.8
#> 12 worst 3 100 12.1µs 13.2µs 73721. 0B 22.1
#> 13 best 5 100 11.6µs 12.8µs 75969. 0B 22.8
#> 14 worst 5 100 12.8µs 14.1µs 67052. 0B 20.1
#> 15 best 10 100 11.5µs 12.6µs 77085. 0B 23.1
#> 16 worst 10 100 13.5µs 14.7µs 66383. 0B 13.3
#> 17 best 50 100 12.3µs 13.6µs 71675. 0B 21.5
#> 18 worst 50 100 22.3µs 23.6µs 41590. 0B 12.5
#> 19 best 100 100 13.8µs 15µs 65014. 0B 19.5
#> 20 worst 100 100 33.6µs 34.9µs 28214. 0B 8.47