The R Project SVN R

R Under development (unstable) (2023-03-26 r84067) -- "Unsuffered Consequences"
Copyright (C) 2023 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> #### Testing  UseMethod() and even more NextMethod()
> #### -------------------- 
> #### i.e.,  S3 methods *only*. For S4, see  reg-S4.R
> ##                                          ~~~~~~~~
> 
> ###-- Group methods
> 
> ## previous versions used print() and hit an auto-printing bug.
> 
> ### Arithmetic "Ops" :
> ">.bar" <- function(...) {cat("using >.bar\n"); FALSE}
> ">.foo" <- function(...) {cat("using >.foo\n"); TRUE}
> Ops.foo <- function(...) {
+     cat("using Ops.foo\n")
+     NextMethod()
+ }
> Ops.bar <- function(...) {
+     cat("using Ops.bar\n")
+     TRUE
+ }
> 
> x <- 2:4 ; class(x) <- c("foo", "bar")
> y <- 4:2 ; class(y) <- c("bar", "foo")
> 
> ## The next 4 give a warning each about incompatible methods:
> x > y
[1] FALSE FALSE  TRUE
Warning message:
Incompatible methods (">.foo", ">.bar") for ">" 
> y < x # should be the same (warning msg not, however)
[1] FALSE FALSE  TRUE
Warning message:
Incompatible methods ("Ops.bar", "Ops.foo") for "<" 
> x == y
[1] FALSE  TRUE FALSE
Warning message:
Incompatible methods ("Ops.foo", "Ops.bar") for "==" 
> x <= y
[1]  TRUE  TRUE FALSE
Warning message:
Incompatible methods ("Ops.foo", "Ops.bar") for "<=" 
> 
> x > 3 ##[1] ">.foo"
using >.foo
[1] TRUE
> 
> rm(list=">.foo")
> x > 3 #-> "Ops.foo" and ">.bar"
using Ops.foo
using >.bar
[1] FALSE
> 
> 
> 
> ### ------------  was ./mode-methods.R till R ver. 1.0.x ----------------
> 
> ###-- Using Method Dispatch on "mode" etc :
> ## Tests S3 dispatch with the class attr forced to be data.class
> ## Not very relevant when S4 methods are around, but kept for historical interest
> abc <- function(x, ...) {
+     cat("abc: Before dispatching; x has class `", class(x), "':", sep="")
+     str(x)
+     UseMethod("abc", x) ## UseMethod("abc") (as in S) fails
+ }
> 
> abc.default <- function(x, ...) sys.call()
> 
> "abc.(" <- function(x)
+     cat("'(' method of abc:", deparse(sys.call(sys.parent())),"\n")
> abc.expression <- function(x)
+     cat("'expression' method of abc:", deparse(sys.call(sys.parent())),"\n")
> 
> abc(1)
abc: Before dispatching; x has class `numeric': num 1
abc.default(1)
> e0 <- expression((x))
> e1 <- expression(sin(x))
> abc(e0)
abc: Before dispatching; x has class `expression':  expression((x))
'expression' method of abc: abc.expression(e0) 
> abc(e1)
abc: Before dispatching; x has class `expression':  expression(sin(x))
'expression' method of abc: abc.expression(e1) 
> abc(e0[[1]])
abc: Before dispatching; x has class `(': language, mode "(": (x)
'(' method of abc: `abc.(`(e0[[1]]) 
> abc(e1[[1]])
abc: Before dispatching; x has class `call': language sin(x)
abc.default(e1[[1]])
> 
> 
> ## Some tests for `nameOfClass()`, called from inherits()
> ClassX <- structure(list(), name = "ClassX",
+                     class = c("S3pp_class", "S3pp_object"))
> 
> classx_instance <- structure(list(), class = c("ClassX", "S3pp_object"))
> 
> nameOfClass.S3pp_class <- function(x) attr(x, "name", TRUE)
> nameOfClass.foo <- function(x) "bar"
> 
> stopifnot(exprs = {
+     inherits(classx_instance, "ClassX")
+     inherits(classx_instance, ClassX)
+     ## ignore class on a character object
+     isTRUE(inherits(1, structure("numeric", class = "foo")))
+     ## make sure class is nor evaluated in calling nameOfClass
+     isFALSE(inherits(1, structure(quote(stop("should not be evaluated")),
+                                   class = "foo")))
+ })
> 
> 
> ## Some tests for `@` dispatching
> ## make sure that
> ## - `@` evals the first args only once,
> ## -  doesn't dispatch for S4
> ## -  works on `.Data` even for nonS4 objects
> 
> x <- structure(list(), class = "foo", prop1 = 'prop1val')
> registerS3method("@", "foo",
+     function(x, name) {
+         stopifnot(typeof(name) == "character", length(name) == 1L)
+         cat(sprintf("called `@.foo`(x = %s, name = '%s')\n",
+                      deparse1(substitute(x), "\n"), name))
+         attr(x, name, TRUE)
+     }
+ )
> x@prop1
called `@.foo`(x = x, name = 'prop1')
[1] "prop1val"
> 
> abc <- x
> abc@prop1
called `@.foo`(x = abc, name = 'prop1')
[1] "prop1val"
> 
> {
+     cat("new x\n")
+     structure(list(), class = "foo", prop1 = 'prop1val')
+ }@prop1
new x
called `@.foo`(x = {
    cat("new x\n")
    structure(list(), class = "foo", prop1 = "prop1val")
}, name = 'prop1')
[1] "prop1val"
> 
> makeActiveBinding("ax", function(x) {
+     cat("evaluating ax\n")
+     get("x", envir = parent.frame())
+ }, environment())
> 
> ax@prop1
evaluating ax
called `@.foo`(x = ax, name = 'prop1')
[1] "prop1val"
> 
> stopifnot(exprs = {
+     identical( x@prop1, "prop1val")
+     identical(ax@prop1, "prop1val")
+ 
+     identical(letters@.Data, letters)
+ })
called `@.foo`(x = x, name = 'prop1')
evaluating ax
called `@.foo`(x = ax, name = 'prop1')
> 
> try(letters@foo) # error
Error in letters@foo : 
  no applicable method for `@` applied to an object of class "character"
> 
> # doesn't dispatch for S4
> setClass("Person",
+   slots = c(
+     name = "character",
+     age = "numeric"
+   )
+ )
> 
> `@.Person` <- function(x, name) {
+   stop("called @.Person()\n")
+ }
> 
> p <- new("Person", name = "Who", age = -1)
> stopifnot(p@name == "Who")
> 
> 
> ## Some tests for `chooseOpsMethod()`, called from C DispatchGroup() when
> ## 2 methods are found
> foo_obj <- structure(1, class = "foo")
> bar_obj <- structure(1, class = "bar")
> 
> `+.foo` <- function(e1, e2) "foo"
> `+.bar` <- function(e1, e2) "bar"
> 
> invisible(foo_obj + bar_obj)  # Warning: Incompatible methods
Warning message:
Incompatible methods ("+.foo", "+.bar") for "+" 
> 
> chooseOpsMethod.bar <- function(x, y, mx, my, cl, reverse) TRUE
> 
> stopifnot(exprs = {
+     identical(foo_obj + bar_obj, "bar")
+     identical(bar_obj + foo_obj, "bar")
+ })
>