Figure out how to avoid bad arithmetic with difftimes

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:

obj + difftime gives a warning about method conflicts (but not informing which "won") and a bad result (wrong numeric result plus a "units" attr attached) (because the winner is Ops.difftime not our vec_arith.obj)
difftime + obj gives a warning + bad result (difftime)

For vctrs on a list-wrapped integer vector with a vec_proxy:

obj + difftime gives a warning + error, but it's unclear
difftime + obj --- believe this is the same

We want to do better than this. A few ideas:

Try to hook into some function used by Ops.difftime.
- attr<-: not in .S3PrimitiveGenerics
- internal workings: in C land, probably not a way to inject code ther
- potentially inherit from difftime to give different opportunities to hook in? but now we're misleading + inherit other behavior
- see if ALTREP can help hook into internals?
Make every time interval class also inherit from Date and try to make the behavior work out.
- also misleading + inheriting other behavior
Abandon vctrs, use S4 only:
- S4 dispatch appears to be slower; is this true and does it matter?
- Lose convenience of vctrs
Try S3 + S4 approach:
- Can't just feed an S4 object into new_vctr
- Container approaches: S3 holding S4 or S4 holding S3
- Dual S3+S4 behavior: need to check precedence order, overhead

Beginning some experimentation.

[Updated with a couple of S3+S4 approaches. The best difftime-interop approaches are S4 w/ slot, or S4 contains-ing a setOldClass-ed S3, as they actually allow dispatch to new code. Hopefully the latter approach could save some implementation effort vs. the former. S3 approaches seem lower effort, but the best difftime-interop I've been able to achieve is a confusing warning + error message for the ops with the difftimes, rather than an actual result or helpful error message Might want to test dispatch speed of these various approaches on a few different operations.]
[Updated with an additional promising asS4-based approach. Added construction time benchmark and sample methods preparing for second benchmark. S4 construction seems potentially slow.]
[Updated with bugfixes, more benchmarks. Identified but didn't fully fix some bugs / questionable areas with the 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.]
[Updated with more bugfixes.]
[Updated with more FIXME notes regarding S4 bit not being unset in some cases.]
[Updated with typo fixes plus s3s4_oldclass3 approach that is like s3s4_oldclass2 but always, even potentially-needlessly for internal operations, uses asS4(obj, FALSE) instead of unclass to try to avoid surprises.]
[Updated with s3s4_wrapped_oldclass4 approach that uses a list wrapper to try to avoid need for vector copies when we want to get its data as a result without an S4 bit set (unlike oldclass3 which allows these potentially-very-confusing/bad outputs), but unlike oldclass2 approaches allows internal use of operations that appear to work with S4 bit set even though they are on basic types that it'd be rude/impossible to fix general behavior for.].
[Updated with initialize methods and fixed using multiple inheritance in s3s4_contains approach.]
[Updated with 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

The prototypes still don't quite make sense... S4 bit unset but class the S4 class and with a .S3Class attribute (though .S3Class part could be an efficiency thing)

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:

Suppose epicalendar uses no additional args, and another package specifies an S4Class.
- Loading the other package and then epicalendar seems to work okay: no complaints and getClass keeps the extra information.
- Loading epicalendar and then the other package, if the other package used 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

Loading epicalendar and then the other package, if the other package used 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?)

brookslogan / epicalendar

Figure out how to avoid bad arithmetic with difftimes #1