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.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 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.1And 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