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) 7.2µs 8.63µs 109367. 0B 43.8
#> 2 foo_S3(x) 2.44µs 2.83µs 314948. 0B 31.5
#> 3 foo_S4(x) 2.65µs 3.19µs 298680. 0B 29.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) 13.14µs 15.07µs 62747. 0B 50.2
#> 2 bar_S4(x, y) 7.19µs 8.37µs 114306. 0B 45.7A 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 7.16µs 8.67µs 109466. 0B 54.8
#> 2 worst 3 15 7.33µs 8.79µs 107920. 0B 64.8
#> 3 best 5 15 7.17µs 8.77µs 107567. 0B 53.8
#> 4 worst 5 15 7.43µs 9.02µs 104872. 0B 63.0
#> 5 best 10 15 7.21µs 8.69µs 108439. 0B 65.1
#> 6 worst 10 15 7.62µs 9.08µs 104409. 0B 62.7
#> 7 best 50 15 7.79µs 9.31µs 101588. 0B 61.0
#> 8 worst 50 15 9.53µs 11.36µs 83320. 0B 50.0
#> 9 best 100 15 8.21µs 9.34µs 95497. 0B 19.1
#> 10 worst 100 15 11.65µs 12.97µs 75013. 0B 15.0
#> 11 best 3 100 7.08µs 8.23µs 118373. 0B 11.8
#> 12 worst 3 100 7.44µs 8.62µs 112995. 0B 22.6
#> 13 best 5 100 7.09µs 8.3µs 117385. 0B 11.7
#> 14 worst 5 100 7.68µs 8.88µs 109778. 0B 11.0
#> 15 best 10 100 7.18µs 8.31µs 117254. 0B 23.5
#> 16 worst 10 100 8.09µs 9.24µs 105336. 0B 10.5
#> 17 best 50 100 7.63µs 8.82µs 110291. 0B 22.1
#> 18 worst 50 100 12.9µs 14.07µs 69183. 0B 6.92
#> 19 best 100 100 8.45µs 9.67µs 100290. 0B 10.0
#> 20 worst 100 100 17.72µs 19.09µs 51194. 0B 10.2And 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 8.78µs 10µs 96048. 0B 19.2
#> 2 worst 3 15 9.19µs 10.4µs 93310. 0B 18.7
#> 3 best 5 15 8.97µs 10.1µs 95708. 0B 19.1
#> 4 worst 5 15 9.31µs 10.6µs 91848. 0B 18.4
#> 5 best 10 15 8.97µs 10.2µs 95089. 0B 28.5
#> 6 worst 10 15 9.7µs 11µs 86303. 0B 17.3
#> 7 best 50 15 9.81µs 11.2µs 86617. 0B 17.3
#> 8 worst 50 15 13.03µs 14.4µs 67283. 0B 13.5
#> 9 best 100 15 11.1µs 12.4µs 76834. 0B 15.4
#> 10 worst 100 15 17.15µs 18.7µs 51896. 0B 10.4
#> 11 best 3 100 8.8µs 10.2µs 94117. 0B 28.2
#> 12 worst 3 100 9.19µs 10.5µs 91750. 0B 18.4
#> 13 best 5 100 8.96µs 10.3µs 93013. 0B 18.6
#> 14 worst 5 100 9.85µs 11.1µs 86696. 0B 17.3
#> 15 best 10 100 9.1µs 10.5µs 91578. 0B 18.3
#> 16 worst 10 100 10.87µs 12.2µs 79443. 0B 15.9
#> 17 best 50 100 10.16µs 11.4µs 84632. 0B 16.9
#> 18 worst 50 100 19.73µs 21.2µs 45983. 0B 9.20
#> 19 best 100 100 11.41µs 12.8µs 75262. 0B 15.1
#> 20 worst 100 100 31.31µs 32.7µs 29825. 0B 5.97