What should the method call context look like?

[hadley]

e.g. what do you expect the results of the following to be?

library(S7)

f <- new_generic("f", dispatch_args = "x")
method(f, class_character) <- function(x) sys.call()
f("x")

f <- new_generic("f", dispatch_args = "x")
method(f, class_character) <- function(x) parent.frame()
f("x")

f <- new_generic("f", dispatch_args = "x")
method(f, class_character) <- function(x) stop("!")
f("x")
traceback()

[mmaechler]

I did not try the current implementation, so can honestly voice my expectation (in the sense of "desirability"):

• every time when redefining f, I expect both the old/previous generic and the old method to be "gone".

e.g. what do you expect the results of the following to be?

f <- new_generic("f", dispatch_args = "x")
method(f, "character") <- function(x) sys.call()
f()

the above f() should probably give an error, because it calls a generic which should dispatch on 'x' and we have no method for "missing" (in S4 parlance); even if we could define one (could we?) we haven't done so here.

f <- new_generic("f", dispatch_args = "x")
method(f, "character") <- function(x) parent.frame()
f("x")

Should return the 'evaluation frame' of the generic.. (and I have no clue what that would be)

f <- new_generic("f", dispatch_args = "x")
method(f, "character") <- function(x) stop("!")
f("x")
traceback()

indeed should raise an error with message "!". I would not care so much about the traceback(); in some way it should of course correspond to the one above (with parent.frame()).

[lawremi]

I agree that it makes sense for the method to be called by the generic and for everything to be consistent with that. This is only possible though if we eliminate the next method case, most simply by passing an up-casted object to the generic.

[hadley]

The traceback currently looks like this:

5: stop("!") at #1
4: (structure(function (x) 
   stop("!"), class = c("R7_method", "function", "R7_object"), object_class = structure(function (generic, 
       signature, fun) 
   {
       if (is.character(signature)) {
           signature <- list(signature)
       }
       new_object(generic = generic, signature = signature, .data = fun)
   }, name = "R7_method", parent = structure(function (.data) 
   new_object(.data), name = "function", parent = structure(function () 
   {
       out <- .Call(R7_object_)
       class(out) <- "R7_object"
       out
   }, name = "R7_object", properties = list(), constructor = function () 
   {
       out <- .Call(R7_object_)
       class(out) <- "R7_object"
       out
   }, validator = function (x) 
    ...
3: .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1)) at dispatch.R#10
2: method_call()
1: f("x")

I think we need to at least make it:

5: stop("!") at #1
4: method(f, "character")(x)
3: .Call(method_call_, sys.call(-1), sys.function(-1), sys.frame(-1)) at dispatch.R#10
2: method_call()
1: f("x")

I'm not sure if we want to somehow elide the method_call() and .Call as well:

3: stop("!") at #1
2: method(f, "character")(x)
1: f("x")

In either case, @ltierney will need to give me some pointers as to how to achieve this.

[hadley]

The traceback is now the rather unwieldy:

6: stop("!") at #1
5: (structure(function (x) 
   stop("!"), S7_class = structure(function (.data = class_missing, 
       generic = class_missing, signature = class_missing) 
   new_object(fun(.data = .data), generic = generic, signature = signature), name = "S7_method", parent = structure(list(
       class = "function", constructor_name = "fun", constructor = function (.data = class_missing) 
       {
           if (is_class_missing(.data)) {
               .data <- base_default(name)
           }
           .data
       }, validator = function (object) 
       {
           if (base_class(object) != name) {
               sprintf("Underlying data must be <%s> not <%s>", 
                   name, base_class(object))
           }
       }), class = "S7_base_class"), properties = list(generic = structure(list(
       name = "generic", class = structure(function (.data = class_missing, 
           name = class_missing, methods = class_missing, dispatch_args = class_missing) 
       new_object(fun(.data = .data), name = name, methods = methods, 
           dispatch_args = dispatch_args), name = "S7_generic", parent = structure(list(
           class = "function", constructor_name = "fun", constructor = function (.data = class_missing) 
           {
               if (is_class_missing(.data)) {
                   .data <- base_default(name)
               }
               .data
           }, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), properties = list(name = structure(list(
           name = "name", class = structure(list(class = "character", 
               constructor_name = "character", constructor = function (.data = class_missing) 
               {
                   if (is_class_missing(.data)) {
                     .data <- base_default(name)
                   }
                   .data
               }, validator = function (object) 
               {
                   if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                       name, base_class(object))
                   }
               }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           default = NULL), class = "S7_property"), methods = structure(list(
           name = "methods", class = structure(list(class = "environment", 
               constructor_name = "environment", constructor = function (.data = class_missing) 
               {
                   if (is_class_missing(.data)) {
                     .data <- base_default(name)
                   }
                   .data
               }, validator = function (object) 
               {
                   if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                       name, base_class(object))
                   }
               }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           default = NULL), class = "S7_property"), dispatch_args = structure(list(
           name = "dispatch_args", class = structure(list(class = "character", 
               constructor_name = "character", constructor = function (.data = class_missing) 
               {
                   if (is_class_missing(.data)) {
                     .data <- base_default(name)
                   }
                   .data
               }, validator = function (object) 
               {
                   if (base_class(object) != name) {
                     sprintf("Underlying data must be <%s> not <%s>", 
                       name, base_class(object))
                   }
               }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           default = NULL), class = "S7_property")), abstract = FALSE, constructor = function (.data = class_missing, 
           name = class_missing, methods = class_missing, dispatch_args = class_missing) 
       new_object(fun(.data = .data), name = name, methods = methods, 
           dispatch_args = dispatch_args), class = c("S7_class", 
       "S7_object")), getter = NULL, setter = NULL, default = NULL), class = "S7_property"), 
       signature = structure(list(name = "signature", class = structure(list(
           class = "list", constructor_name = "list", constructor = function (.data = class_missing) 
           {
               if (is_class_missing(.data)) {
                   .data <- base_default(name)
               }
               .data
           }, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
           default = NULL), class = "S7_property")), abstract = FALSE, constructor = function (.data = class_missing, 
       generic = class_missing, signature = class_missing) 
   new_object(fun(.data = .data), generic = generic, signature = signature), class = c("S7_class", 
   "S7_object")), class = c("S7_method", "function", "S7_object"
   ), generic = structure(function (x, ...) 
   S7::S7_dispatch(), S7_class = structure(function (.data = class_missing, 
       name = class_missing, methods = class_missing, dispatch_args = class_missing) 
   new_object(fun(.data = .data), name = name, methods = methods, 
       dispatch_args = dispatch_args), name = "S7_generic", parent = structure(list(
       class = "function", constructor_name = "fun", constructor = function (.data = class_missing) 
       {
           if (is_class_missing(.data)) {
               .data <- base_default(name)
           }
           .data
       }, validator = function (object) 
       {
           if (base_class(object) != name) {
               sprintf("Underlying data must be <%s> not <%s>", 
                   name, base_class(object))
           }
       }), class = "S7_base_class"), properties = list(name = structure(list(
       name = "name", class = structure(list(class = "character", 
           constructor_name = "character", constructor = function (.data = class_missing) 
           {
               if (is_class_missing(.data)) {
                   .data <- base_default(name)
               }
               .data
           }, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
       default = NULL), class = "S7_property"), methods = structure(list(
       name = "methods", class = structure(list(class = "environment", 
           constructor_name = "environment", constructor = function (.data = class_missing) 
           {
               if (is_class_missing(.data)) {
                   .data <- base_default(name)
               }
               .data
           }, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
       default = NULL), class = "S7_property"), dispatch_args = structure(list(
       name = "dispatch_args", class = structure(list(class = "character", 
           constructor_name = "character", constructor = function (.data = class_missing) 
           {
               if (is_class_missing(.data)) {
                   .data <- base_default(name)
               }
               .data
           }, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"), getter = NULL, setter = NULL, 
       default = NULL), class = "S7_property")), abstract = FALSE, constructor = function (.data = class_missing, 
       name = class_missing, methods = class_missing, dispatch_args = class_missing) 
   new_object(fun(.data = .data), name = name, methods = methods, 
       dispatch_args = dispatch_args), class = c("S7_class", "S7_object"
   )), class = c("S7_generic", "function", "S7_object"), name = "f", methods = <environment>, dispatch_args = "x"), signature = list(
       structure(list(class = "character", constructor_name = "character", 
           constructor = function (.data = class_missing) 
           {
               if (is_class_missing(.data)) {
                   .data <- base_default(name)
               }
               .data
           }, validator = function (object) 
           {
               if (base_class(object) != name) {
                   sprintf("Underlying data must be <%s> not <%s>", 
                     name, base_class(object))
               }
           }), class = "S7_base_class"))))("x", ... = ...)
4: eval(S7_dispatched_call, envir = sys.frame(-1))
3: eval(S7_dispatched_call, envir = sys.frame(-1))
2: S7::S7_dispatch()
1: f("x")

[t-kalinowski]

Resolved via #486 and #483.