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")

+ })

>