The R Project SVN R

## 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

abc <- x

abc@prop1

{

    cat("new x\n")

    structure(list(), class = "foo", prop1 = 'prop1val')

}@prop1

makeActiveBinding("ax", function(x) {

    cat("evaluating ax\n")

    get("x", envir = parent.frame())

}, environment())

ax@prop1

stopifnot(exprs = {

    identical( x@prop1, "prop1val")

    identical(ax@prop1, "prop1val")

    identical(letters@.Data, letters)

})

try(letters@foo) # error

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