Open brookslogan opened 2 months ago
Beginning some experimentation.
s4only_contains
, s3s4_contains
, and s3s4_oldclass2
where obj + int/double wasn't actually dispatching to an implementation that's controlled (only fixed/controlled the + int part for the s3s4_contains2
approach). It seems that S3 dispatch is faster for regular generics. Much-faster S4 for binary +
pointed toward the bug / questionable result, but it appears that the fixed s3s4_oldclass2
for ints maintains an advantage over S3 approaches, though not as fast as the approaches currently accepting the default behavior that aren't dispatching to custom impls. At least s3s4_oldclass2
and maybe the others can flexibly choose whether or not to accept this impl... but apparently must mask out more than just a difftime default impl. Perhaps they never were actually hitting the difftime Ops like the other approaches and were instead fighting against this other default impl.]asS4(obj, FALSE)
instead of unclass
to try to avoid surprises.]s3s4_contains
approach.]s3s4_oldclass5
which uses prototype =
and sets some more attributes, maybe fitting a bit better with S4 ecosystem though it may need some additional overrides.]#' @export
s3only_simple <- function(x) {
new_vctr(x, class = "s3only_simple")
}
#' @method vec_arith s3only_simple
#' @export
#' @export vec_arith.s3only_simple
vec_arith.s3only_simple <- function(op, x, y, ...) {
UseMethod("vec_arith.s3only_simple", y)
}
#' @method vec_arith.s3only_simple integer
#' @export
vec_arith.s3only_simple.integer <- function(op, x, y, ...) {
switch(
op,
"+" = new_vctr(unclass(x) + 7L*y, class = "s3only_simple"),
"-" = new_vctr(unclass(x) - 7L*y, class = "s3only_simple"),
stop_incompatible_op(op, x, y)
)
}
#' @method vec_arith.s3only_simple default
#' @export
vec_arith.s3only_simple.default <- function(op, x, y, ...) {
stop_incompatible_op(op, x, y)
}
# GOOD:
# s3only_simple(1:5) + 5L
# BAD:
# s3only_simple(1:5) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3only_simple(1:5)
#' @export
s3only_wrapped <- function(x) {
new_vctr(list(x), class = "s3only_wrapped")
}
#' @method vec_arith s3only_wrapped
#' @export
#' @export vec_arith.s3only_wrapped
vec_arith.s3only_wrapped <- function(op, x, y, ...) {
UseMethod("vec_arith.s3only_wrapped", y)
}
#' @method vec_arith.s3only_wrapped integer
#' @export
vec_arith.s3only_wrapped.integer <- function(op, x, y, ...) {
switch(
op,
"+" = new_vctr(list(unclass(x)[[1L]] + 7L*y), class = "s3only_wrapped"),
"-" = new_vctr(list(unclass(x)[[1L]] - 7L*y), class = "s3only_wrapped"),
stop_incompatible_op(op, x, y)
)
}
#' @method vec_arith.s3only_wrapped default
#' @export
vec_arith.s3only_wrapped.default <- function(op, x, y, ...) {
stop_incompatible_op(op, x, y)
}
#' @export
vec_proxy.s3only_wrapped <- function(x, ...) {
return (x[[1L]])
}
# GOOD:
# s3only_wrapped(1:5) + 5L
# OKAY, BUT NOT GREAT:
# s3only_wrapped(1:5) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3only_wrapped(1:5)
setOldClass("difftime") # FIXME might need more information to be correct / compatible with other oldclasses of it
#' @export
s4only_contains <- setClass("s4only_contains", contains = "numeric")
# XXX probably over-inheriting
#' @export
setMethod("initialize", "s4only_contains", function(.Object, dat, ...) {
S3Part(.Object) <- dat
.Object
})
#' @export
setMethod("+", c(e1 = "s4only_contains", e2 = "integer"), function(e1, e2) {
e1@.Data <- e1@.Data + 7L*e2
e1
# might potentially be able to dispatch to vec_arith via callNextMethod ??
})
#' @export
setMethod("+", c(e1 = "s4only_contains", e2 = "difftime"), function(e1, e2) {
stop("no") # placeholder for real operation or improved error message
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s4only_contains"), function(e1, e2) {
stop("no")
})
# GOOD:
# s4only_contains(1:5) + 5L
# s4only_contains(1:5) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s4only_contains(1:5)
#' @export
s4only_slot <- setClass("s4only_slot", slots = c(dat = "numeric"))
#' @export
setMethod("initialize", "s4only_slot", function(.Object, dat, ...) {
.Object@dat <- dat
.Object
})
#' @export
setMethod("+", c(e1 = "s4only_slot", e2 = "integer"), function(e1, e2) {
e1@dat <- e1@dat + 7L*e2
e1
})
#' @export
setMethod("+", c(e1 = "s4only_slot", e2 = "difftime"), function(e1, e2) {
stop("no")
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s4only_slot"), function(e1, e2) {
stop("no")
})
# GOOD:
# s4only_slot(dat = 1:5) + 5L
# s4only_slot(dat = 1:5) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s4only_slot(dat = 1:5)
# TODO S3 + S4 approaches; Methods_for_S3, setOldClass
# setOldClass("vctrs_vec")
# setOldClass("s3s4_oldclass")
setOldClass(c("s3s4_oldclass", "vctrs_vctr"))
#' @export
s3s4_oldclass <- function(x) {
new_vctr(x, class = "s3s4_oldclass")
}
#' @method vec_arith s3s4_oldclass
#' @export
#' @export vec_arith.s3s4_oldclass
vec_arith.s3s4_oldclass <- function(op, x, y, ...) {
# print("at vec_arith")
UseMethod("vec_arith.s3s4_oldclass", y)
}
#' @method vec_arith.s3s4_oldclass default
#' @export
vec_arith.s3s4_oldclass.default <- function(op, x, y, ...) {
stop_incompatible_op(op, x, y)
}
#' @method vec_arith.s3s4_oldclass integer
#' @export
vec_arith.s3s4_oldclass.integer <- function(op, x, y, ...) {
switch(
op,
# XXX some fix may have made it possible to use @.Data here
"+" = new_vctr(unclass(x) + 7L*y, class = "s3s4_oldclass"),
"-" = new_vctr(unclass(x) - y, class = "s3s4_oldclass"),
stop_incompatible_op(op, x, y)
)
}
# #' @export
# setMethod("+", c(e1 = "s3s4_oldclass", e2 = "integer"), function(e1, e2) {
# # print("HERE")
# asS4(new_vctr(unclass(e1) + e2, class = "s3s4_oldclass"))
# })
# # XXX these implementations would be inherited by s3s4_contains, but yield
# # s3s4_oldclass results that (may?) have the S4 flag set, rather than
# # s3s4_contains results:
# #' @export
# setMethod("+", c(e1 = "s3s4_oldclass", e2 = "integer"), function(e1, e2) {
# # NOTE this only triggers for s3s4_contains, not s3s4_oldclass
# new_vctr(unclass(e1) + 7L*e2, class = "s3s4_oldclass")
# })
# #' @export
# setMethod("+", c(e1 = "s3s4_oldclass", e2 = "difftime"), function(e1, e2) {
# stop("DOESN'T (DIRECTLY) TRIGGER")
# })
# #' @export
# setMethod("+", c(e1 = "difftime", e2 = "s3s4_oldclass"), function(e1, e2) {
# stop("DOESN'T (DIRECTLY) TRIGGER")
# })
# GOOD:
# s3s4_oldclass(1:5) + 5L
# BAD (likely from primitives not finding S4 flag):
# s3s4_oldclass(1:5) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3s4_oldclass(1:5)
#' @export
s3s4_contains <- setClass("s3s4_contains", contains = "s3s4_oldclass")
#' @export
setMethod("initialize", "s3s4_contains", function(.Object, dat, ...) {
# .Object@.Data <- new_vctr(dat, class = "s3s4_oldclass")
# S3Part(.Object) <- new_vctr(dat, class = "s3s4_oldclass")
S3Part(.Object, strictS3 = TRUE) <- new_vctr(dat, class = "s3s4_oldclass")
.Object
})
#' @export
setMethod("+", c(e1 = "s3s4_contains", e2 = "integer"), function(e1, e2) {
# S3Part(e1) <- S3Part(e1) + e2
S3Part(e1, strictS3 = TRUE) <- S3Part(e1, strictS3 = TRUE) + e2
e1
})
#' @export
setMethod("+", c(e1 = "s3s4_contains", e2 = "difftime"), function(e1, e2) {
stop("no")
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s3s4_contains"), function(e1, e2) {
stop("no")
})
# not using strictS3 can lead to issues printing sometimes due to S4 flag set
# GOOD, though default print isn't so great:
# s3s4_contains(s3s4_oldclass(1:5)) + 5L
# s3s4_contains(s3s4_oldclass(1:5)) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3s4_contains(s3s4_oldclass(1:5))
# GOOD, this is caught!
# s3s4_contains(s3s4_oldclass(1:5)) + 5
# XXX ??? (maybe due to not using strictS3 = TRUE):
# s3s4_contains(s3s4_oldclass(1:5)) |> S3Part() |> attributes()
# s3s4_contains(1:5) |> S3Part() |> attributes()
# # FIXME "structure" below is from `ts` example; is it appropriate?
# # FIXME probably misunderstanding purpose of S4Class... S4Class is supposed to be pre-existing because it provides a slot spec
# #' @export
# s3s4_contains2_inner <- setClass("s3s4_contains2_inner", contains = "structure")
# setOldClass(c("s3s4_oldclass", "vctrs_vctr"), S4Class = "s3s4_contains2_inner")
# FIXME probably it's not the right thing, plus it messes up other things involving vctrs_vctr
# # s3s4_contains2 <- setClass("s3s4_contains2", contains = "s3s4_oldclass")
# #' @export
# s3s4_contains2 <- setClass("s3s4_contains2", contains = "s3s4_contains2_inner")
# # s3s4_contains2(s3s4_oldclass(1:4))
# # getClass("s3s4_contains2") |> getSlots()
# #' @export
# setMethod("initialize", "s3s4_contains2", function(.Object, dat, ...) {
# # .Object@.Data <- new_vctr(dat, class = "s3s4_oldclass")
# S3Part(.Object) <- new_vctr(dat, class = "s3s4_oldclass")
# .Object
# })
# # GOOD, though default print isn't so great:
# # s3s4_contains2(s3s4_oldclass(1:5)) + 5L
# # s3s4_contains2(s3s4_oldclass(1:5)) + as.difftime(5, units = "secs")
# # as.difftime(5, units = "secs") + s3s4_contains2(s3s4_oldclass(1:5))
# # need to override this too:
# # s3s4_contains2(s3s4_oldclass(1:5)) + 5
#' @export
s3s4_oldclass2 <- function(x) {
asS4(new_vctr(x, class = "s3s4_oldclass2"))
}
# These wouldn't actually be used:
# #' @method vec_arith s3s4_oldclass2
# #' @export
# #' @export vec_arith.s3s4_oldclass2
# vec_arith.s3s4_oldclass2 <- function(op, x, y, ...) {
# UseMethod("vec_arith.s3s4_oldclass2", y)
# }
# #' @method vec_arith.s3s4_oldclass2 integer
# #' @export
# vec_arith.s3s4_oldclass2.integer <- function(op, x, y, ...) {
# switch(
# op,
# "+" = asS4(new_vctr(unclass(x) + y, class = "s3s4_oldclass2")),
# "-" = asS4(new_vctr(unclass(x) - y, class = "s3s4_oldclass2")),
# stop_incompatible_op(op, x, y)
# )
# }
# # FIXME should probably be a class vector?
# setOldClass("s3s4_oldclass2")
setOldClass(c("s3s4_oldclass2", "vctrs_vctr"))
#' @export
setMethod("+", c(e1 = "s3s4_oldclass2", e2 = "integer"), function(e1, e2) {
# print("HERE")
asS4(new_vctr(asS4(e1, FALSE) + 7L*e2, class = "s3s4_oldclass2"))
})
#' @export
setMethod("+", c(e1 = "s3s4_oldclass2", e2 = "difftime"), function(e1, e2) {
stop("no")
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s3s4_oldclass2"), function(e1, e2) {
stop("no")
})
# Default `show` gives a confusing error message.
#' @ export
setMethod("show", "s3s4_oldclass2", function(object) {
print(asS3(object, complete = FALSE))
})
# GOOD:
# s3s4_oldclass2(s3s4_oldclass2(1:5)) + 5L
# s3s4_oldclass2(s3s4_oldclass2(1:5)) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3s4_oldclass2(s3s4_oldclass2(1:5))
#' @export
s3s4_oldclass3 <- function(x) {
asS4(new_vctr(x, class = "s3s4_oldclass3"))
}
# These wouldn't actually be used:
# #' @method vec_arith s3s4_oldclass3
# #' @export
# #' @export vec_arith.s3s4_oldclass3
# vec_arith.s3s4_oldclass3 <- function(op, x, y, ...) {
# UseMethod("vec_arith.s3s4_oldclass3", y)
# }
# #' @method vec_arith.s3s4_oldclass3 integer
# #' @export
# vec_arith.s3s4_oldclass3.integer <- function(op, x, y, ...) {
# switch(
# op,
# "+" = asS4(new_vctr(unclass(x) + y, class = "s3s4_oldclass3")),
# "-" = asS4(new_vctr(unclass(x) - y, class = "s3s4_oldclass3")),
# stop_incompatible_op(op, x, y)
# )
# }
setOldClass("s3s4_oldclass3")
#' @export
setMethod("+", c(e1 = "s3s4_oldclass3", e2 = "integer"), function(e1, e2) {
asS4(new_vctr(unclass(e1) + 7L*e2, class = "s3s4_oldclass3"))
})
#' @export
setMethod("+", c(e1 = "s3s4_oldclass3", e2 = "difftime"), function(e1, e2) {
stop("no")
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s3s4_oldclass3"), function(e1, e2) {
stop("no")
})
# Default `show` gives a confusing error message.
#' @ export
setMethod("show", "s3s4_oldclass3", function(object) {
print(asS3(object, complete = FALSE))
})
# GOOD:
# s3s4_oldclass3(s3s4_oldclass(1:5)) + 5L
# s3s4_oldclass3(s3s4_oldclass(1:5)) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3s4_oldclass3(s3s4_oldclass(1:5))
#' @export
s3s4_wrapped_oldclass4 <- function(x) {
asS4(new_vctr(list(x), class = "s3s4_wrapped_oldclass4"))
}
#' @export
vec_proxy.s3s4_wrapped_oldclass4 <- function(x) {
# Use `unclass` rather than `asS4(,FALSE)` for speed as `[[` appears to work
# even with S4 bit set:
unclass(x)[[1L]]
}
setOldClass("s3s4_wrapped_oldclass4")
#' @export
setMethod("+", c(e1 = "s3s4_wrapped_oldclass4", e2 = "integer"), function(e1, e2) {
asS4(new_vctr(list(unclass(e1)[[1L]] + 7L*e2), class = "s3s4_wrapped_oldclass4"))
})
#' @export
setMethod("+", c(e1 = "s3s4_wrapped_oldclass4", e2 = "difftime"), function(e1, e2) {
stop("no")
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s3s4_wrapped_oldclass4"), function(e1, e2) {
stop("no")
})
#' @ export
setMethod("show", "s3s4_wrapped_oldclass4", function(object) {
print(asS3(object, complete = FALSE))
})
# GOOD:
# s3s4_wrapped_oldclass4(1:5) + 5L
# s3s4_wrapped_oldclass4(1:5) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3s4_wrapped_oldclass4(1:5)
s3s4_oldclass5_class_arg_for_vctrs <- `attr<-`("s3s4_oldclass5", "package", "epicalendar")
s3s4_oldclass5_s3_class <- c("s3s4_oldclass5", "vctrs_vctr")
#' @export
s3s4_oldclass5 <- function(x) {
# XXX not getting class attr package attr out of this, vctrs must drop; consider reintroducing.
asS4(new_vctr(x, class = s3s4_oldclass5_class_arg_for_vctrs, .S3Class = s3s4_oldclass5_s3_class))
}
setOldClass(s3s4_oldclass5_s3_class, prototype = s3s4_oldclass5(integer(0L)))
# probably want to override some initialize and coerce S4 methods
# this sort of approach works:
#' @export
setMethod("+", c(e1 = "s3s4_oldclass5", e2 = "integer"), function(e1, e2) {
asS4(new_vctr(unclass(asS4(e1, FALSE, FALSE)) + 7L*e2, class = s3s4_oldclass5_class_arg_for_vctrs, .S3Class = s3s4_oldclass5_s3_class))
})
# this also works, but may be a bit slower:
# #' @method vec_arith s3s4_oldclass5
# #' @export
# #' @export vec_arith.s3s4_oldclass5
# vec_arith.s3s4_oldclass5 <- function(op, x, y, ...) {
# UseMethod("vec_arith.s3s4_oldclass5", y)
# }
# #' @method vec_arith.s3s4_oldclass5 integer
# #' @export
# vec_arith.s3s4_oldclass5.integer <- function(op, x, y, ...) {
# # maybe don't route through new_vctr here. Maybe just set up a vec_restore that doesn't use it.
# switch(
# op,
# "+" = asS4(new_vctr(unclass(asS4(x, FALSE, FALSE)) + 7L*y, class = s3s4_oldclass5_class_arg_for_vctrs, .S3Class = s3s4_oldclass5_s3_class), TRUE),
# "-" = asS4(new_vctr(unclass(asS4(x, FALSE, FALSE)) - 7L*y, class = s3s4_oldclass5_class_arg_for_vctrs, .S3Class = s3s4_oldclass5_s3_class), TRUE),
# stop_incompatible_op(op, x, y)
# )
# }
# #' @method vec_arith.s3s4_oldclass5 default
# #' @export
# vec_arith.s3s4_oldclass5.default <- function(op, x, y, ...) {
# stop_incompatible_op(op, x, y)
# }
#' @export
setMethod("+", c(e1 = "s3s4_oldclass5", e2 = "difftime"), function(e1, e2) {
stop("no")
})
#' @export
setMethod("+", c(e1 = "difftime", e2 = "s3s4_oldclass5"), function(e1, e2) {
stop("no")
})
# Default `show` gives a confusing error message.
#' @ export
setMethod("show", "s3s4_oldclass5", function(object) {
print(asS3(object, complete = FALSE))
})
# GOOD:
# s3s4_oldclass5(s3s4_oldclass5(1:5)) + 5L
# s3s4_oldclass5(s3s4_oldclass5(1:5)) + as.difftime(5, units = "secs")
# as.difftime(5, units = "secs") + s3s4_oldclass5(s3s4_oldclass5(1:5))
# GOOD:
# s3s4_oldclass5(s3s4_oldclass5(1:5)) + 5
# s3s4_oldclass5(s3s4_oldclass5(1:5)) - 5
# s3s4_oldclass5(s3s4_oldclass5(1:5)) == 5L
# #' @export
# contains_vctr <- setClass("contains_vctr", contains = "vctrs_vctr")
# #' @export
# setMethod("+", c(e1 = "contains_vctr", e2 = "integer"), function(e1, e2) {
# asS4(new_vctr(list(unclass(e1)[[1L]] + 7L*e2), class = "contains_vctr"))
# unclass(e1@.Data) + e2
# # probably can't take advantage of vec_arith if we wanted to
# })
# #' @export
# setMethod("+", c(e1 = "contains_vctr", e2 = "difftime"), function(e1, e2) {
# stop("no")
# })
# #' @export
# setMethod("+", c(e1 = "difftime", e2 = "contains_vctr"), function(e1, e2) {
# stop("no")
# })
# #' @export
# s3s4_contains3_inner <- function(x) {
# new_vctr(x, class = "s3s4_contains3_inner")
# }
# #' @method vec_arith s3s4_contains3_inner
# #' @export
# #' @export vec_arith.s3s4_contains3_inner
# vec_arith.s3s4_contains3_inner <- function(op, x, y, ...) {
# # print("at vec_arith")
# UseMethod("vec_arith.s3s4_contains3_inner", y)
# }
# #' @method vec_arith.s3s4_contains3_inner default
# #' @export
# vec_arith.s3s4_contains3_inner.default <- function(op, x, y, ...) {
# stop_incompatible_op(op, x, y)
# }
# #' @method vec_arith.s3s4_contains3_inner integer
# #' @export
# vec_arith.s3s4_contains3_inner.integer <- function(op, x, y, ...) {
# switch(
# op,
# # XXX some fix may have made it possible to use @.Data here
# "+" = new_vctr(unclass(x) + 7L*y, class = "s3s4_contains3_inner"),
# "-" = new_vctr(unclass(x) - y, class = "s3s4_contains3_inner"),
# stop_incompatible_op(op, x, y)
# )
# }
# #' @export
# s3s4_contains3 <- setClass("s3s4_contains3", contains = "integer")
# # ??? not sure if this does anything (wanted):
# #' @export
# setOldClass(c("s3s4_contains3_inner", "vctrs_vctr"), S4Class = "s3s4_contains3")
# setMethod("+", c(e1 = "s3s4_contains3"), function(e1, e2) {
# callNextMethod()
# })
# # s3s4_contains3(1:5)
# # s3s4_contains3(1:5) |> attributes()
# # s3s4_contains3(1:5) |> isS4()
# # s3s4_contains3(1:5) + 5L
# # s3s4_contains3(s3s4_contains3_inner(1:5)) + 5L
# # s3s4_contains3(s3s4_contains3_inner(1:5)) + as.difftime(5, units = "secs")
# # as.difftime(5, units = "secs") + s3s4_contains3(s3s4_contains3_inner(1:5))
# # s3s4_contains3(s3s4_contains3_inner(1:5)) + 5
#' @export
get_value <- function(x) UseMethod("get_value")
#' @export
get_value.s3only_simple <- function(x) unclass(x)
#' @export
get_value.s3only_wrapped <- function(x) unclass(x)[[1L]]
#' @export
get_value.s4only_contains <- function(x) x@.Data
#' @export
get_value.s4only_slot <- function(x) x@dat
#' @export
get_value.s3s4_oldclass <- function(x) unclass(x)
# FIXME while ability to do vvv is / would be nice, maybe in general should fall through to the s3 variant, if that actually works?
#' @export
get_value.s3s4_contains <- function(x) unclass(asS3(x))
#' @export
get_value.s3s4_oldclass2 <- function(x) asS4(x, FALSE)
#' @export
get_value.s3s4_oldclass3 <- function(x) unclass(x)
#' @export
get_value.s3s4_wrapped_oldclass4 <- function(x) vec_proxy(x)
#' @export
get_value.s3s4_oldclass5 <- function(x) `attr<-`(unclass(asS4(x, FALSE, FALSE)), ".S3Class", NULL)
dat <- 1:100 + 1L
# bench::mark(
# s3only_simple(dat),
# s3only_wrapped(dat),
# s4only_contains(dat),
# s4only_slot(dat = dat),
# s3s4_oldclass(dat),
# s3s4_contains(s3s4_oldclass(dat)), # in reality we'd have even more overhead wrapping this in a convenient constructor function
# s3s4_oldclass2(dat),
# s3s4_oldclass3(dat),
# s3s4_wrapped_oldclass4(dat),
# s3s4_oldclass5(dat),
# check = FALSE,
# min_iterations = 5e4,
# max_iterations = 1e7
# )
#> # A tibble: 10 × 13
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory time gc
#> <bch:expr> <bch:t> <bch:t> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list> <list> <list>
#> 1 s3only_simp… 4.28µs 4.61µs 214976. NA 12.4 103924 6 483.42ms <NULL> <NULL> <bench_tm> <tibble>
#> 2 s3only_wrap… 4.77µs 5.12µs 191235. NA 14.7 91220 7 477ms <NULL> <NULL> <bench_tm> <tibble>
#> 3 s4only_cont… 60.85µs 64.19µs 15450. NA 14.5 49953 47 3.23s <NULL> <NULL> <bench_tm> <tibble>
#> 4 s4only_slot… 15.82µs 16.83µs 58894. NA 14.1 49988 12 848.78ms <NULL> <NULL> <bench_tm> <tibble>
#> 5 s3s4_oldcla… 4.19µs 4.54µs 216598. NA 14.5 104412 7 482.06ms <NULL> <NULL> <bench_tm> <tibble>
#> 6 s3s4_contai… 56.2µs 58.92µs 16864. NA 13.8 49959 41 2.96s <NULL> <NULL> <bench_tm> <tibble>
#> 7 s3s4_oldcla… 4.83µs 5.24µs 187757. NA 14.5 90538 7 482.21ms <NULL> <NULL> <bench_tm> <tibble>
#> 8 s3s4_oldcla… 4.84µs 5.34µs 184467. NA 14.5 88906 7 481.96ms <NULL> <NULL> <bench_tm> <tibble>
#> 9 s3s4_wrappe… 5.45µs 5.87µs 167510. NA 12.5 80415 6 480.06ms <NULL> <NULL> <bench_tm> <tibble>
#> 10 s3s4_oldcla… 5.26µs 5.68µs 173757. NA 14.5 83842 7 482.53ms <NULL> <NULL> <bench_tm> <tibble>
my_s3only_simple <- s3only_simple(dat)
my_s3only_wrapped <- s3only_wrapped(dat)
my_s4only_contains <- s4only_contains(dat)
my_s4only_slot <- s4only_slot(dat = dat)
my_s3s4_oldclass <- s3s4_oldclass(dat)
my_s3s4_contains <- s3s4_contains(s3s4_oldclass(dat))
my_s3s4_oldclass2 <- s3s4_oldclass2(dat)
my_s3s4_oldclass3 <- s3s4_oldclass3(dat)
my_s3s4_wrapped_oldclass4 <- s3s4_wrapped_oldclass4(dat)
my_s3s4_oldclass5 <- s3s4_oldclass5(dat)
# bench::mark(
# my_s3only_simple |> get_value(),
# my_s3only_wrapped |> get_value(),
# my_s4only_contains |> get_value(),
# my_s4only_slot |> get_value(),
# my_s3s4_oldclass |> get_value(),
# my_s3s4_contains |> get_value(),
# my_s3s4_oldclass2 |> get_value(),
# my_s3s4_oldclass3 |> get_value(),
# my_s3s4_wrapped_oldclass4 |> get_value(),
# my_s3s4_oldclass5 |> get_value(),
# min_iterations = 1e5,
# max_iterations = 1e7
# )
#> # A tibble: 10 × 13
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory time gc
#> <bch:expr> <bch:> <bch:> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list> <list> <list>
#> 1 get_value(my_… 1.17µs 1.27µs 757625. NA 19.1 356358 9 470ms <int> <NULL> <bench_tm> <tibble>
#> 2 get_value(my_… 1.28µs 1.38µs 702675. NA 19.3 291400 8 415ms <int> <NULL> <bench_tm> <tibble>
#> 3 get_value(my_… 5.53µs 5.88µs 168144. NA 13.5 99992 8 595ms <int> <NULL> <bench_tm> <tibble>
#> 4 get_value(my_… 1.07µs 1.15µs 854082. NA 17.1 400018 8 468ms <int> <NULL> <bench_tm> <tibble>
#> 5 get_value(my_… 1.18µs 1.27µs 756355. NA 19.1 356567 9 471ms <int> <NULL> <bench_tm> <tibble>
#> 6 get_value(my_… 2.02µs 2.19µs 442249. NA 16.8 211181 8 478ms <int> <NULL> <bench_tm> <tibble>
#> 7 get_value(my_… 1.71µs 1.88µs 512300. NA 19.0 242559 9 473ms <int> <NULL> <bench_tm> <tibble>
#> 8 get_value(my_… 1.25µs 1.34µs 712642. NA 16.9 337348 8 473ms <int> <NULL> <bench_tm> <tibble>
#> 9 get_value(my_… 3.95µs 4.3µs 227932. NA 14.5 109712 7 481ms <int> <NULL> <bench_tm> <tibble>
#> 10 get_value(my_… 2.14µs 2.37µs 408623. NA 19.1 192471 9 471ms <int> <NULL> <bench_tm> <tibble>
# bench::mark(
# my_s3only_simple + 2L,
# my_s3only_wrapped + 2L,
# my_s4only_contains + 2L,
# my_s4only_slot + 2L,
# my_s3s4_oldclass + 2L,
# my_s3s4_contains + 2L,
# my_s3s4_oldclass2 + 2L,
# my_s3s4_oldclass3 + 2L,
# my_s3s4_wrapped_oldclass4 + 2L,
# my_s3s4_oldclass5 + 2L,
# check = FALSE,
# min_iterations = 1e5,
# max_iterations = 1e7
# )
#> # A tibble: 10 × 13
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory time gc
#> <bch:expr> <bch:t> <bch:t> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list> <list> <list>
#> 1 my_s3only_si… 10.81µs 11.78µs 82600. NA 12.4 99985 15 1.21s <NULL> <NULL> <bench_tm> <tibble>
#> 2 my_s3only_wr… 11.94µs 12.8µs 77447. NA 12.4 99984 16 1.29s <NULL> <NULL> <bench_tm> <tibble>
#> 3 my_s4only_co… 74.83µs 78.44µs 12623. NA 12.3 99903 97 7.91s <NULL> <NULL> <bench_tm> <tibble>
#> 4 my_s4only_sl… 12.73µs 13.71µs 72144. NA 13.7 99981 19 1.39s <NULL> <NULL> <bench_tm> <tibble>
#> 5 my_s3s4_oldc… 10.8µs 11.55µs 85699. NA 12.9 99985 15 1.17s <NULL> <NULL> <bench_tm> <tibble>
#> 6 my_s3s4_cont… 89.34µs 96.55µs 10242. NA 13.7 99866 134 9.75s <NULL> <NULL> <bench_tm> <tibble>
#> 7 my_s3s4_oldc… 8.6µs 9.26µs 105493. NA 14.8 99986 14 947.79ms <NULL> <NULL> <bench_tm> <tibble>
#> 8 my_s3s4_oldc… 7.98µs 8.48µs 116858. NA 14.0 99988 12 855.64ms <NULL> <NULL> <bench_tm> <tibble>
#> 9 my_s3s4_wrap… 9µs 9.7µs 102035. NA 14.3 99986 14 979.91ms <NULL> <NULL> <bench_tm> <tibble>
#> 10 my_s3s4_oldc… 9.29µs 10.08µs 98148. NA 13.7 99986 14 1.02s <NULL> <NULL> <bench_tm> <tibble>
# FIXME note that approaches with the S4 flag set will automatically inherit
# some behaviors for obj + integer and obj + double. In certain cases, they may
# match the behavior we actually want, but in general, we need the ability to
# override these behaviors. Unlike S3 + difftime, that is straightforward, as
# demonstrated with the obj + integer example. However, that does mean that
# there could be a wide range of behaviors that need to be manually disabled, or
# that they need to be combined with a list-wrap approach like s3only_wrapped to
# help at least get some sort of hard failure when unintended numerical
# operation defaults are used.
# my_s3only_simple + 2
# my_s3only_wrapped + 2
# my_s4only_contains + 2 # no error by default
# my_s4only_slot + 2 # nonideal error message by default
# my_s3s4_oldclass + 2
# my_s3s4_contains + 2
# my_s3s4_oldclass2 + 2
# my_s3s4_oldclass3 + 2 # no error by default
# bench::mark(
# get_value(s3only_simple(1:1000) + 2L),
# get_value(s3only_wrapped(1:1000) + 2L),
# get_value(s4only_contains(1:1000) + 2L),
# get_value(s4only_slot(dat = 1:1000) + 2L),
# get_value(s3s4_oldclass(1:1000) + 2L),
# get_value(s3s4_contains(s3s4_oldclass(1:1000)) + 2L),
# get_value(s3s4_oldclass2(1:1000) + 2L),
# get_value(s3s4_oldclass3(1:1000) + 2L),
# get_value(s3s4_wrapped_oldclass4(1:1000) + 2L),
# get_value(s3s4_oldclass5(1:1000) + 2L),
# min_iterations = 1e5,
# max_iterations = 1e7
# )
#> # A tibble: 10 × 13
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory time gc
#> <bch:expr> <bch:t> <bch:t> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list> <list> <list>
#> 1 get_value(s3… 19.1µs 20.4µs 48061. NA 11.5 99976 24 2.08s <int> <NULL> <bench_tm> <tibble>
#> 2 get_value(s3… 21.4µs 22.7µs 43738. NA 11.4 99974 26 2.29s <int> <NULL> <bench_tm> <tibble>
#> 3 get_value(s4… 165.2µs 172.8µs 5748. NA 11.5 99801 199 17.36s <int> <NULL> <bench_tm> <tibble>
#> 4 get_value(s4… 33.3µs 35.4µs 27711. NA 13.0 99953 47 3.61s <int> <NULL> <bench_tm> <tibble>
#> 5 get_value(s3… 18.9µs 20.2µs 48989. NA 11.8 99976 24 2.04s <int> <NULL> <bench_tm> <tibble>
#> 6 get_value(s3… 157.5µs 167.9µs 5910. NA 13.1 99779 221 16.88s <int> <NULL> <bench_tm> <tibble>
#> 7 get_value(s3… 17.2µs 19.1µs 51942. NA 13.0 99975 25 1.93s <int> <NULL> <bench_tm> <tibble>
#> 8 get_value(s3… 16.6µs 18.2µs 54454. NA 12.5 99977 23 1.84s <int> <NULL> <bench_tm> <tibble>
#> 9 get_value(s3… 21.8µs 23.7µs 41769. NA 12.1 99971 29 2.39s <int> <NULL> <bench_tm> <tibble>
#> 10 get_value(s3… 19.4µs 21µs 47004. NA 13.2 99972 28 2.13s <int> <NULL> <bench_tm> <tibble>
# my_s3only_simple + as.difftime(2, units = "secs")
# my_s3only_wrapped + as.difftime(2, units = "secs")
# my_s4only_contains + as.difftime(2, units = "secs")
# my_s4only_slot + as.difftime(2, units = "secs")
# my_s3s4_oldclass + as.difftime(2, units = "secs")
# my_s3s4_contains + as.difftime(2, units = "secs")
# my_s3s4_oldclass2 + as.difftime(2, units = "secs")
# my_s3s4_oldclass3 + as.difftime(2, units = "secs")
# my_s3s4_wrapped_oldclass4 + as.difftime(2, units = "secs")
# my_s3s4_oldclass5 + as.difftime(2, units = "secs")
Collecting some findings [doesn't include s3s4_oldclass3, s3s4_wrapped_oldclass4]:
s3only_simple, s3s4_oldclass fail to block obj + difftime or difftime + obj ops. s3only_wrapped gives unclear warning + error. Rest allow custom behavior.
s4only_contains, ~s3s4_contains~ [purposely fixed], ~s3s4_oldclass2~ [incidentally fixed... maybe by the proper setOldClass call?] have even more default behaviors to block (say, obj + double), but unlike difftime situation above are able to override them. s4only_slot has a similar story but already "blocks" many of these behaviors with an unclear error message by default.
Construction of s4_only_contains might be very very slow, and of s4only_slot and of s3s4_contains very slow. This seems to be the heaviest operation compared to the others tested, or at least it has the slowest of the slow.
"Regular" methods for s4only_contains might be very slow, and on s3s4_contains a bit slow.
Addition on s4only_contains might be very slow, and of s3only_simple, s3only_wrapper, s4only_slot, s3s4_oldclass somewhat slow.
(Benchmarks above don't reflect overall impact on real programs based on amounts of these operations performed....)
It seems best to eliminate s3only_simple, s3s4_oldclass, and s3only_wrapped based on the apparent inability override default difftime arithmetic operations. This leaves s4only_contains, s4only_slot, s3s4_contains, and s3s4_oldclass2.
All the remaining methods have issues with additional other inherited behaviors. s4only_slot is slightly better correctness-wise because these default ops often error, though the others have the option of getting better performance by not overriding a default that does the intended thing.
s3s4_oldclass2 may have better computational performance compared to the rest of the remaining methods.
s3s4_oldclass2 also doesn't involve as many levels of inheritance as s3s4_contains, and benefits from vctrs methods unlike s4only_contains and s4only_slot.
The ~two~ three main contenders explored then seem to be s3s4_oldclass2 (highest potential given enough implementation effort [and maybe with incidental bugfix mentioned above it also has good default failsafes]) and s4only_slot or s3s4_contains (more default failsafes). One lingering uncertainty is the extent of the default functionality that they are inheriting; if the set of methods with such problematic defaults is not determined solely by base R, then there is always the threat that another package will introduce more undesired default functionality that will introduce bugs. Though there doesn't really seem to be an alternative that avoids this threat; the ones that don't have the default behavior for object + double are actually in worse shape because they have nonideal behavior on the critical object + difftime case with no apparent way to avoid it.
[Might need to revisit correctness/performance yet again... it looks like unclass
won't unset the S4 bit at least in s3s4_oldclass2 approach, which might potentially cause some issues or slow down performance to manually unset? But might be able to just use asS3 (with default complete = TRUE) instead of unclass + asS3.]
Performance of approaches that unset S4 bit of intermediates/results that might potentially need it shows that it does significantly degrade oldclass2 approach, though it still appears to be among the faster approaches. Isolating just the dat extraction:
bench::mark(
asS3(my_s3s4_oldclass2),
unclass(my_s3s4_oldclass2),
unclass(asS3(my_s3s4_oldclass2, complete = FALSE)),
asS3(unclass(my_s3s4_oldclass2), complete = FALSE),
asS4(my_s3s4_oldclass2, flag = FALSE),
asS4(my_s3s4_oldclass2, FALSE),
min_iterations = 1e5,
max_iterations = 1e9
)
#> # A tibble: 6 × 13
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory
#> <bch:expr> <bch> <bch:> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list>
#> 1 asS3(my_s3… 622ns 685ns 1380961. NA 29.1 5.22e5 11 378ms <int> <NULL>
#> 2 unclass(my… 170ns 187ns 5040264. NA 24.9 2.02e6 10 402ms <int> <NULL>
#> 3 unclass(as… 744ns 807ns 1158042. NA 28.9 5.21e5 13 450ms <int> <NULL>
#> 4 asS3(uncla… 766ns 858ns 1097782. NA 26.4 4.98e5 12 454ms <int> <NULL>
#> 5 asS4(my_s3… 615ns 674ns 1386622. NA 29.2 6.17e5 13 445ms <int> <NULL>
#> 6 asS4(my_s3… 569ns 640ns 1495269. NA 31.6 6.63e5 14 443ms <int> <NULL>
#> # ℹ 2 more variables: time <list>, gc <list>
list(
asS3(my_s3s4_oldclass2),
unclass(my_s3s4_oldclass2),
unclass(asS3(my_s3s4_oldclass2, complete = FALSE)),
asS3(unclass(my_s3s4_oldclass2), complete = FALSE),
asS4(my_s3s4_oldclass2, flag = FALSE),
asS4(my_s3s4_oldclass2, FALSE)
) |>
vapply(isS4, logical(1L))
#> [1] FALSE TRUE FALSE FALSE FALSE FALSE
(Note that bench::mark doesn't appear to complain about mismatches in the S4 flags. Is this because it's not an issue to leave it set on vanilla integer vectors, or is it a missed edge case?)
[It seems like maybe the overhead could mostly be from copying the object due to smart-CoW rules. This might point to using wrapping approaches to try to reduce the cost of copies, though this might also cause more copying in other places due to refcount increments and mysteries of refcounts / older "many" gcflag not being able to decrement as much as we'd expect in some cases...]
[As for correctness... it seems like primitives on all-integer/MISSING types might be sealed, but binary ops allow passing some mix of basic types and ANY... but they seem to be ignored despite documentation suggesting that S4 dispatch would be used by the primitive. So it may not be easy to accidentally change behavior of primitives on basic types. However, this could confuse a user:
`class<-`(asS4(my_s3s4_oldclass2, FALSE), "Date") # success
#> [...] [success]
asdf <- `class<-`(unclass(my_s3s4_oldclass2), "Date")
asdf
#> Object of class "Date"
#> Error in .S3Class(object) :
#> 'S3Class' only defined for extensions of "oldClass" or classes with a data part: not true of class "Date"
]
[Perhaps construction/operation of other approaches can be sped up... for example, s3s4_contains
objects can be constructed via S3Part<-
on a protoype object + the oldclass constructor and this seems twice as fast as the automatic constructor function, though it still takes 10x the time of oldclass approaches directly.]
The s3s4_wrapped_oldclass4
approach doesn't seem to help performance in the above benchmarks. It does have an easier time avoiding potential issues with the S4 bit internally as it only needs S4-flagged lists' [[
to work rather than any collection of operations (or it could also just use asS4(obj, FALSE)[[1L]]
but it seems expected that that will be slower), and does likely automatically block more unwanted default operations (though with unclear error messages). However, it does require a vec_proxy()
and anything else this entails.
But the above benchmarks are probably not on the scale we'd work with in epiprocess + epipredict. A more realistic size might be around 50000 for 3 years of US state-level data. However, it appears that the asS4(obj, FALSE)
overhead is either not actually related to copying, or that the copying that occurs does not have to copy the underlying vector data (at least not immediately), since it appears to have pretty stable across vector sizes:
oc2s1 <- s3s4_oldclass2(1L)
oc2s100 <- s3s4_oldclass2(1:100 + 1L)
oc2s1000 <- s3s4_oldclass2(1:1000 + 1L)
oc2s50000 <- s3s4_oldclass2(1:50000 + 1L)
oc2s3e6 <- s3s4_oldclass2(1:3e6 + 1L)
bench::mark(
get_value(oc2s1),
get_value(oc2s100),
get_value(oc2s1000),
get_value(oc2s50000),
get_value(oc2s3e6),
check = FALSE,
min_iterations = 1e5,
max_iterations = 1e9
)
#> # A tibble: 5 × 13
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory
#> <bch:expr> <bch:> <bch:> <dbl> <bch:byt> <dbl> <int> <dbl> <bch:tm> <list> <list>
#> 1 get_value(… 1.67µs 1.86µs 513100. NA 18.9 244227 9 476ms <NULL> <NULL>
#> 2 get_value(… 1.73µs 1.94µs 489891. NA 18.9 233055 9 476ms <NULL> <NULL>
#> 3 get_value(… 1.72µs 1.93µs 497789. NA 18.9 236763 9 476ms <NULL> <NULL>
#> 4 get_value(… 1.72µs 1.91µs 501292. NA 18.9 238434 9 476ms <NULL> <NULL>
#> 5 get_value(… 1.73µs 1.94µs 491780. NA 18.9 234438 9 477ms <NULL> <NULL>
#> # ℹ 2 more variables: time <list>, gc <list>
So there appears to be no strong incentive to switch to the wrapper approach. There might still be incentive to use a non-wrapped oldclass4 approach, relying internally on certain operations on basic types still working even with the S4 flag set, though this seems like an opportunity for nonobvious bugs and might be relying on undocumented behavior that could change (or perhaps has changed in past R versions) without notice.
An s3s4_slot
approach should be considered as well, forwarding to vctrs implementations. Seems likely similar to s3only_slot
, though perhaps more convenient but with higher overhead.
Perhaps S3Class
/ S3Class<-
/ the .S3Class
attr could provide some ways to improve unwanted defaults of oldclass approaches.
For S4 approaches, a custom initialize
method should also be considered.
[It looks like making this change changes construction benchmarks from around this:
#> expression min median `itr/sec` mem_alloc `gc/sec` n_itr n_gc total_time result memory
#> 3 s4only_contains(d… 166.85µs 177.17µs 5611. NA 10.1 49910 90 8.89s <NULL> <NULL>
#> 4 s4only_slot(dat =… 97.43µs 101.91µs 9665. NA 10.1 49948 52 5.17s <NULL> <NULL>
to around this:
#> 3 s4only_contains… 61.19µs 64.61µs 15317. NA 13.8 49955 45 3.26s <NULL>
#> 4 s4only_slot(dat… 15.72µs 17.12µs 55228. NA 14.4 49987 13 905.11ms <NULL>
For s3s4 approaches, see implementation issue below where it seems multiple inheritance is being used. But there I had difficulties getting a single-inheritance of an oldClass to actually work properly, and am still not sure how to do it.]
Also s3s4_contains
may be using contains =
wrong; it may need the S4 class name which would by default be just the first in the S3 class vector. [And need to oldClass vctrs_vec
seems indicative that this is indeed doing multiple inheritance rather than S3 class vec.] (And the oldclass{2,3,4} monsters may not supposed to be a thing at all, not sure.)
[The problem blocking moving to proper usage might be that the setOldClass for s3s4_oldclass
was wrong, not including vctrs_vctr.]
[Fixed.]
TODO consider S7
TODO consider version-tagged format
TODO spinning this investigation off into an Issue probably wasn't the best idea; probably need to set up an ignored folder or separate repo, or maybe a vignette
When the S4 flag is auto-dropped seems complicated:
a <- asS4(2)
b <- asS4(3)
d <- 2
e <- 3
a_with_attr <- a
attr(a_with_attr, "aname") <- "aval"
isS4(a)
isS4(b)
isS4(a_with_attr)
# the results here have the flag:
isS4(asS4(2) + 2)
isS4(2 + asS4(2))
# if copy is involved, the result can drop the flag:
isS4(a + 2)
# but not always:
isS4(a + asS4(2))
isS4(d + asS4(2))
isS4(asS4(2) + a)
isS4(asS4(2) + d)
# these also drop the flag:
isS4(a + a)
isS4(a + b)
isS4(a + d)
isS4(d + a)
isS4(2 + a)
# what about setting attrs? these all have the flag:
isS4(asS4(2) + 3)
isS4(asS4(`attr<-`(2, "aname", "aval")) + 3)
isS4(`attr<-`(a,"aname","aval"))
isS4(`attr<-`(a,"aname","aval") + 3)
isS4(a_with_attr + 3)
isS4(a_with_attr + a_with_attr)
TODO it seems like oldclass approaches may be able to use @.Data
(unlike contains approach, which seems to need S3Part, though I thought some docs suggested the opposite).
TODO test asS4 vs as(, "S4") and as(, "S3") vs. trying to provide an initialize and using new vs. getClass vs. manuallying setting ".S3Class" and "package" attrs somewhere (maybe not same place(s)?) vs. .... [might need S4Class = ....]
?S3Part
suggests that as(obj, "S3")
and as(obj, "S4")
is friendlier than asS3
and asS4
, doing more checking and interpretation. While the checking part might be true for as "S4", the interpretation I'm not sure about. It seems like as "S3" does less work than asS3 (at least without setting complete = FALSE
), as it appears to just unset the S4 flag but leave the S4 class name as the class attribute (plus the "package" attr attr) and the S3 class vector as a .S3Class attr. But perhaps this and asS3(complete = FALSE) suggest that some attrs are indeed missing from asS4 S4-ification... as does the fact that |> as("S3") |> as("S4")
seems to recover the original for some toy example but |> asS3() |> asS4()
does not. But |> as("S3")
also doesn't seem to make sense as a result, despite the original appearing to contain the appropriate attrs ("class" "package" + .S3Class, though I'm not sure why the latter is needed as it hasn't been registered as an old class that might have differing class vector tails.. unless providing S4Class = does that.).]Try also triple S3 class vectors to see if it simplifies any NextMethod vs. callNextMethod related issues with oldclass and/or contains.
(Also make sure to try overriding S4 group generics, checking on primitive function listings, etc.)
TODO: try a contains-vctrs_vec approach [... or, probably mentioned before, contains-ing an S3 "subclass" of it... though is this just s3s4_contains?] TODO: try multiple inheritance to pair an appropriate data prototype with extension of vctr? TODO: compare oldclass approach objects vs. their getClass prototypes
TODO: better setOldClass on difftime
Various creations and conversions seem pretty inconsistent. Making S3 objects more S4-like with attrs makes the conversions agree more of the time. Not sure how to use S4Part
without inheriting unwanted behaviors; prototype
seems to work better.
abc_s3_class <- c("s3a", "s3b", "s3c")
abc_s3_class_with_package <- `attr<-`(abc_s3_class, "package", "epicalendar")
abc_s4_class_name <- "s4abc"
#' @export
abc_s4_class_ctor <- setClass(abc_s4_class_name, contains = "integer", slots = c("some_attr" = "character"))
#' @export
setOldClass(abc_s3_class, S4Class = abc_s4_class_name)
abc_s3_class_ctor <- function(x) {
x |>
`attr<-`(".S3Class", abc_s3_class) |>
`attr<-`("some_attr", "attr_value") |>
`class<-`(abc_s3_class_with_package) |>
# `class<-`(abc_s3_class) |>
identity()
# structure(x,
# .S3Class = abc_s3_class,
# class = abc_s3_class_with_package)
}
my_abc_s3 <- abc_s3_class_ctor(1:5)
my_abc_s3 |> attributes()
my_abc_s3 |> asS4() |> attributes()
my_abc_s3 |> as("S4") |> attributes()
new("s3a") |> attributes()
# new(abc_s3_class) |> attributes()
my_abc_s3 |> asS4() |> asS3() |> attributes()
my_abc_s3 |> asS4() |> asS3(complete = FALSE) |> attributes()
my_abc_s3 |> asS4() |> as("S3") |> attributes()
my_abc_s3 |> asS4() |> S3Part() |> attributes() # bizarre... setting things to integer class, or to the S4 class, and/or having S4 flag set.....
my_abc_s3 |> as("S4") |> asS3() |> attributes()
my_abc_s3 |> as("S4") |> asS3(complete = FALSE) |> attributes()
my_abc_s3 |> as("S4") |> as("S3") |> attributes()
my_abc_s3 |> as("S4") |> S3Part() |> attributes()
my_abc_s3 |> as("S4") |> S3Part() |> isS4()
my_abc_s3 |> as("S4") |> S3Part(strictS3 = TRUE) |> attributes()
bench::mark(
abc_s3_class_ctor(1:5),
as(abc_s3_class_ctor(1:5), "S4"),
as(abc_s3_class_ctor(1:5), "S4") |> as("S3"),
asS4(abc_s3_class_ctor(1:5)),
asS4(abc_s3_class_ctor(1:5)) |> asS3() |> attributes(),
asS4(abc_s3_class_ctor(1:5)) |> asS3(complete = FALSE) |> attributes(),
check = FALSE,
min_iterations = 1e4,
max_iterations = 1e9
)
asS3(abc_s4_class_ctor(1:4)) |> attributes()
asS3(abc_s4_class_ctor(1:4), complete = FALSE) |> attributes()
as(abc_s4_class_ctor(1:4) , "S3") |> attributes()
S3Part(abc_s4_class_ctor(1:4)) |> attributes()
S3Part(abc_s4_class_ctor(1:4), strictS3 = TRUE) |> attributes()
getClass(abc_s3_class)
getClass(abc_s3_class[[1L]])
validObject doesn't seem too picky, or might not even pay attention to oldClasses at all?
# validObject(`class<-`(1:4, "notaclass"))
validObject(abc_s3_class_ctor(1:5))
validObject(abc_s3_class_ctor(1:5) |> `class<-`("s3a"))
validObject(abc_s3_class_ctor(1:5) |> `class<-`("s3b"))
validObject("......." |> `class<-`("s3b"))
validObject(asS4(abc_s3_class_ctor(1:5)))
# with the generally-not-recommended `prototype` approach, we avoid a bunch of
# crazy inheritance from the `contains` proxy:
setOldClass(c("s3ap", "s3bp"), prototype = `class<-`(integer(0L), c("s3ap", "s3bp")))
getClass(c("s3ap", "s3bp"))
new("s3ap")
new("s3ap") |> attributes()
[Testing some more, perhaps new
is actually producing an object that can inherit vctrs behavior despite not having the vctrs_vctr class? But sometimes this creates infinite loops, e.g., with ==
. And feeding through as("S3") + as("S4") don't recover its format either...]
Investigation into setOldClass on difftime:
setClass("difftime"
+ setOldClass("difftime"
as in the "ts"
example: there are these warnings:Found more than one class "difftime" in cache; using the first, from namespace 'epicalendar'
Also defined by 'difftimealt'
Found more than one class "difftime" in cache; using the first, from namespace 'epicalendar'
Also defined by 'difftimealt'
Warning message:
In rm(list = what, pos = classWhere) : object '.__C__difftime' not found
setClass("difftimeS4"
and setOldClass("difftime", S4Class = "difftimeS4")
--- ... no warning, but still getClass
is the simpler definition!Packages on github seem to use just the simple setOldClass("difftime")
without extra specifications. So we can't rely on ever having the extra info available, unless there is a way to check and force an override. But epicalendar doesn't really need this extra info encoded. But if another (not-on-public-github) package needs it, do we want to avoid interfering with them? That would require matching their spec. But it doesn't seem possible to write down the "correct"(?) spec with contains = "double"
+ the units slot, as this yields:
> Error in makePrototypeFromClassDef(properties, ClassDef, immediate, where) :
in constructing the prototype for class "difftime4": prototype has class "numeric", but the data part specifies class "double"
(I'm basing this "correct" spec on typeof(as.difftime(<integer>, ......))
currently being "double"
. "numeric" could be swapped in instead, but would this cause a worse conflict headache than just being another setOldClass("difftime")
package?)
We want to make sure that obj + difftime and difftime + obj produce sensible results or clear error messages.
For vctrs directly on an integer vector:
For vctrs on a list-wrapped integer vector with a
vec_proxy
:We want to do better than this. A few ideas:
attr<-
: not in .S3PrimitiveGenericsnew_vctr