## accumulate here tests of the relation between S4 and S3 classes

## $<-.data.frame did stupid things with the class attribute
## that clobbered S4 classes extending "data.frame"
## Test that the S4 method (R 2.13.0) works transparently

set.seed(864)

xx <- data.frame(a=rnorm(10),
                 b=as.factor(sample(c("T", "F"), 10, TRUE)),
                 row.names = paste("R",1:10,sep=":"))

setClass("myData", representation(extra = "character"),
         contains = "data.frame")

mx <- new("myData", xx, extra = "testing")

## three kinds of $<-: replace, add, delete (NULL value)

mx$a <- mx$a * 2
xx$a <- xx$a * 2

mx$c <- 1:10
xx$c <- 1:10

mx$b <- NULL
xx$b <- NULL

stopifnot(identical(mx, new("myData", xx, extra = "testing")))
## simple call, only field names
fg <- setRefClass("foo", c("bar", "flag"))
f0 <- new("foo")  # deprecated, but should still work
f1 <- fg(flag = "testing")
f1$bar <- 1
stopifnot(identical(f1$bar, 1))
## add method
fg$methods(showAll = function() c(bar, flag))
stopifnot(all.equal(f1$showAll(), c(1, "testing")))
str(f1)

fg <- setRefClass("foo", list(bar = "numeric", flag = "character",
                              tag = "ANY"),
                  methods = list(addToBar = function(incr) {
                      b <- bar + incr
                      bar <<- b
                      b
                  } )
                  )
fg$lock("flag")
stopifnot(identical(fg$lock(), "flag"))

ff <- new("foo", bar = 1.5)
stopifnot(identical(ff$bar, 1.5))
ff$bar <- pi
stopifnot(identical(ff$bar, pi))
## flag has not yet been set
ff$flag <- "flag test"
stopifnot(identical(ff$flag, "flag test"))
## but no second assign
stopifnot(is(tryCatch(ff$flag <- "new", error = function(e)e), "error"))

## test against generator

f2 <- fg(bar = pi, flag = "flag test")
## identical does not return TRUE if *contents* of env are identical
stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))
## but flag was now assigned once
stopifnot(is(tryCatch(f2$flag <- "new", error = function(e)e), "error"))

str(f2)


## add some accessor methods
fg$accessors("bar")

ff$setBar(1:3)
stopifnot(identical(ff$getBar(), 1:3))

ff$getBar()
stopifnot(all.equal(ff$addToBar(1), 2:4))


## Add a method
fg$methods(barTimes = function(x) {
    "This method multiples field bar by argument x
and this string is self-documentation"
    setBar(getBar() * x)})

ffbar <- ff$getBar()
ff$barTimes(10)
stopifnot(all.equal(ffbar * 10, ff$getBar()))
ff$barTimes(.1)

## inheritance.  redefines flag so should fail:
stopifnot(is(tryCatch(setRefClass("foo2", list(b2 = "numeric",
					       flag = "complex"),
            contains = "foo",
            refMethods = list(addBoth = function(incr) {
                addToBar(incr) #uses inherited class method
                setB2(getB2() + incr)
                })),
          error = function(e)e), "error"))
## but with flag as a subclass of "characters", should work
## Also subclasses "tag" which had class "ANY before
setClass("ratedChar", contains = "character",
         representation(score = "numeric"))
foo2 <- setRefClass("foo2", list(b2 = "numeric", flag = "ratedChar",
				 tag = "numeric"),
	    contains = "foo",
	    methods = list(addBoth = function(incr) {
                addToBar(incr) #uses inherited class method
                b2 <<- b2 + incr
                }))
## now lock the flag field; should still allow one write
foo2$lock("flag")
f2 <- foo2(bar = -3, flag = as("ANY", "ratedChar"),
               b2 = ff$bar, tag = 1.5)
## but not a second one
stopifnot(is(tryCatch(f2$flag <- "Try again",
         error = function(e)e), "error"))
str(f2)
f22 <- foo2(bar = f2$bar)
## same story if assignment follows the initialization
f22$flag <- f2$flag
stopifnot(is(tryCatch(f22$flag <- "Try again",
         error = function(e)e), "error"))
## Exporting superclass object
f22 <- fg(bar = f2$bar, flag = f2$flag)
f2e <- f2$export("foo")
stopifnot(identical(f2e$bar, f22$bar), identical(f2e$flag, f22$flag),
          identical(class(f2e), class(f22)))
stopifnot(identical(f2$flag,  as("ANY", "ratedChar")),
          identical(f2$bar, -3),
          all.equal(f2$b2, 2:4+0))
f2$addBoth(-1)
stopifnot(all.equal(f2$bar, -4), all.equal(f2$b2, 1:3+0))

## test callSuper()
foo3 <- setRefClass("foo3", fields = list(flag2 = "ratedChar"),
            contains = "foo2",
	    methods = list(addBoth = function(incr) {
		callSuper(incr)
		flag2 <<- as(paste(flag, paste(incr, collapse = ", "),
				   sep = "; "),
                             "ratedChar")
                incr
            }))

f2 <- foo2(bar = -3, flag = as("ANY", "ratedChar"), b2 =  1:3)
f3 <- foo3()
f3$import(f2)
stopifnot(all.equal(f3$b2, f2$b2), all.equal(f3$bar, f2$bar),
          all.equal(f3$flag, f2$flag))
f3$addBoth(1)
stopifnot(all.equal(f3$bar, -2), all.equal(f3$b2, 2:4+0),
          all.equal(f3$flag2, as("ANY; 1", "ratedChar")))

## but the import should have used up the one write for $flag
stopifnot(is(tryCatch(f3$flag <- "Try again",
         error = function(e)e), "error"))
str(f3)

## importing the same class (not very useful but documented to work)
f3 <- foo3()
f4 <- foo3(bar = -3, flag = as("More", "ratedChar"), b2 =  1:3, flag2 = f2$flag)
f3$import(f4)
stopifnot(identical(f3$bar, f4$bar),
          identical(f3$flag, f4$flag),
          identical(f3$b2, f4$b2),
          identical(f3$flag2, f4$flag2))

## similar to $import() but using superclass object in the generator call
## The explicitly supplied flag= should override and be allowed
## by the default $initialize()
f3b <- foo3(f2, flag = as("Other", "ratedChar"),
                flag2 = as("More", "ratedChar"))
## check that inherited and direct field assignments worked
stopifnot(identical(f3b$tag, f2$tag),
          identical(f3b$flag, as("Other", "ratedChar")),
          identical(f3b$flag2, as("More", "ratedChar")))
## the $new() method should match the generator function
f3b <- foo3$new(f2, flag = as("Other", "ratedChar"),
                flag2 = as("More", "ratedChar"))
stopifnot(identical(f3b$tag, f2$tag),
          identical(f3b$flag, as("Other", "ratedChar")),
          identical(f3b$flag2, as("More", "ratedChar")))
## a class with an initialize method, and an extra slot (legal, not a good idea)
setOldClass(c("simple.list", "list"))
fg4 <- setRefClass("foo4",
            contains = "foo2",
            methods = list(
              initialize = function(...) {
                  .self$initFields(...)
                  .self@made <<- R.version
                  .self
              }),
            representation = list(made = "simple.list")
            )

f4 <- new("foo4", flag = as("another test", "ratedChar"), bar = 1:3)
stopifnot(identical(f4@made, R.version))

## a trivial class with no fields, using fields = list(), failed up to rev 56035
foo5 <- setRefClass("foo5", fields = list(),
                    methods = list(bar = function(test)
                    paste("*",test,"*")))

f5 <- foo5()
stopifnot(identical( f5$bar("xxx"), paste("*","xxx", "*")))


## simple active binding test
abGen <- setRefClass("ab",
                  fields = list(a = "ANY",
                  b = function(x) if(missing(x)) a else {a <<- x; x}))

ab1 <- abGen(a = 1)

stopifnot(identical(ab1$a, 1), identical(ab1$b, 1))

ab1$b <- 2

stopifnot(identical(ab1$a, 2), identical(ab1$b, 2))

## a simple editor for matrix objects.  Method  $edit() changes some
## range of values; method $undo() undoes the last edit.
mEditor <- setRefClass("matrixEditor",
        fields = list(data = "matrix",
		     edits = "list"),
       methods = list(
     edit = function(i, j, value) {
       ## the following string documents the edit method
       'Replaces the range [i, j] of the
	object by value.
        '
         backup <-
             list(i, j, data[i,j])
         data[i,j] <<- value
         edits <<- c(list(backup),
                     edits)
         invisible(value)
     },
     undo = function() {
       'Undoes the last edit() operation
        and update the edits field accordingly.
        '
         prev <- edits
         if(length(prev)) prev <- prev[[1]]
         else stop("No more edits to undo")
         edit(prev[[1]], prev[[2]], prev[[3]])
         ## trim the edits list
         length(edits) <<- length(edits) - 2
         invisible(prev)
     }
     ))
xMat <- matrix(1:12,4,3)
xx <- mEditor(data = xMat)
xx$edit(2, 2, 0)
xx$data
xx$undo()
mEditor$help("undo")
stopifnot(all.equal(xx$data, xMat))

## add a method to save the object
mEditor$methods(
     save = function(file) {
       'Save the current object on the file
 in R external object format.
'
         base::save(.self, file = file)
     },
     counter = function(i) {
         'The number of items in the i-th edit.
 (Used to test usingMethods())
'
         if(i > 0 && i <= length(edits))
             length(edits[[i]][[3]])
         else
             0L
     }
)

tf <- tempfile()
xx$save(tf) #$
load(tf)
unlink(tf)
stopifnot(identical(xx$data, .self$data))

## tests of $trace() methods
## debugging an object
xx$trace(edit, quote(xxTrace <<- TRUE))

## debugging all objects from class mEditor in method $undo()
mEditor$trace(undo, quote(mETrace <<- TRUE))

xxTrace <- mETrace <- FALSE
xx$edit(2,3,100)
xx$undo()

## will not have changed the xx$undo() method (already used)
stopifnot(identical(xxTrace, TRUE), identical(mETrace, FALSE))

## but a new object works the other way around
xxTrace <- mETrace <- FALSE
xx <- mEditor(data = xMat)
xx$edit(2,3,100)
xx$undo()
stopifnot(identical(xxTrace, FALSE), identical(mETrace, TRUE))



markViewer <- ""
setMarkViewer <- function(what)
    markViewer <<- what

## Inheriting a reference class:  a matrix viewer
mv <- setRefClass("matrixViewer",
    fields = c("viewerDevice", "viewerFile"),
    contains = "matrixEditor",
    methods = list( view = function() {
        dd <- dev.cur(); dev.set(viewerDevice)
        devAskNewPage(FALSE)
        matplot(data, main = paste("After",length(edits),"edits"))
        dev.set(dd)},
        edit = # invoke previous method, then replot
          function(i, j, value) {
            callSuper(i, j, value)
            view()
          }))

## initialize and finalize methods
mv$methods( initialize = function(file = "./matrixView.pdf", ...) {
    viewerFile <<- file
    pdf(viewerFile)
    viewerDevice <<- dev.cur()
    message("Plotting to ", viewerFile)
    dev.set(dev.prev())
    setMarkViewer("ON")
    initFields(...)
  },
  finalize = function() {
    dev.off(viewerDevice)
    setMarkViewer("OFF")
  })

## a counts method to test usingMethods()
mv$methods( counts = function() {
    usingMethods("counter")
    sapply(seq_along(edits), "counter")
})


ff <- mv( data = xMat)
stopifnot(identical(markViewer, "ON")) # check initialize
ff$edit(2,2,0)
ff$data
if(methods:::.hasCodeTools())  # otherwise 'counter' is not visible
    stopifnot(identical(ff$counts(), length(ff$edits[[1]][[3]])))
ff$undo()
stopifnot(all.equal(ff$data, xMat))
rm(ff)
gc()
stopifnot(identical(markViewer, "OFF")) #check finalize

## tests of copying
viewerPlus <- setRefClass("viewerPlus",
                   fields = list( text = "character",
                      viewer = "matrixViewer"))
ff <- mv( data = xMat)
v1 <- viewerPlus(text = letters, viewer = ff)
v2 <- v1$copy()
v3 <- v1$copy(TRUE)
v2$text <- "Hello, world"
v2$viewer$data <- t(xMat) # change a field in v2$viewer
v3$text <- LETTERS
v3$viewer <- mv( data = matrix(nrow=1,ncol=1))
## with a deep copy all is protected, with a shallow copy
## the environment of a copied field remains the same,
## but replacing the whole field should be local
stopifnot(identical(v1$text, letters),
          identical(v1$viewer, ff),
          identical(v2$text, "Hello, world"))
v3 <- v1$copy(TRUE)
v3$viewer$data <- t(xMat) # should modify v1$viewer as well
stopifnot(identical(v1$viewer$data, t(xMat)))

## the field() method
stopifnot(identical(v1$text, v1$field("text")))
v1$field("text", "Now is the time")
stopifnot(identical(v1$field("text"), "Now is the time"))

## setting a non-existent field, or a method, should throw an error
stopifnot(is(tryCatch(v1$field("foobar", 0), error = function(e)e), "error"),
         is(tryCatch(v1$field("copy", 0), error = function(e)e), "error") )

## the methods to extract class definition and generator
stopifnot(identical(v3$getRefClass()$def, getRefClass("viewerPlus")$def),
          identical(v3$getClass(), getClass("viewerPlus")))

## deal correctly with inherited methods and overriding existing
## methods from $methods(...)
refClassA <- setRefClass("refClassA", methods=list(foo=function() "A"))
refClassB <- setRefClass("refClassB", contains="refClassA")
mnames <- objects(getClass("refClassB")@refMethods)
refClassB$methods(foo=function() callSuper())
stopifnot(identical(refClassB()$foo(), "A"))
mnames2 <- objects(getClass("refClassB")@refMethods)
stopifnot(identical(mnames2[is.na(match(mnames2,mnames))], "foo#refClassA"))
refClassB$methods(foo=function() paste(callSuper(), "Version 2"))
stopifnot(identical(refClassB()$foo(), "A Version 2"))
stopifnot(identical(mnames2, objects(getClass("refClassB")@refMethods)))

if(methods:::.hasCodeTools()) {
    ## code warnings assigning locally to field names
    stopifnot(is(tryCatch(mv$methods(test = function(x)
                                 { data <- x[!is.na(x)]; mean(data)}),
                          warning = function(e)e), "warning"))

    ## warnings for nonlocal assignment that is not a field
    stopifnot(is(tryCatch(mv$methods(test2 = function(x) {something <<- data[!is.na(x)]}), warning = function(e)e), "warning"))

    ## error for trying to assign to a method name
    stopifnot(is(tryCatch(mv$methods(test3 = function(x) {edit <<- data[!is.na(x)]}), error = function(e)e), "error"))
} else
    warning("Can't run some tests:  recommended package codetools is not available")

## tests (fragmentary by necessity) of promptClass for reference class
ccon <- textConnection("ctxt", "w")
suppressMessages(promptClass("refClassB", filename = ccon))
## look for a method, inheritance, inherited method
stopifnot(length(c(grep("foo.*refClassA", ctxt),
                   grep("code{foo()}", ctxt, fixed = TRUE),
                   grep("linkS4class{refClassA", ctxt, fixed = TRUE))) >= 3)
close(ccon)
rm(ctxt)


## tests related to subclassing environments.  These really test code in the core, viz. builtin.c
a <- refClassA()
ev <- new.env(parent = a) # parent= arg
stopifnot(is.environment(ev))
foo <- function()"A"; environment(foo) <- a # environment of function
stopifnot(identical(as.environment(a), environment(foo)))
xx <- 1:10; environment(xx) <- a # environment attribute
stopifnot(identical(as.environment(a), environment(xx)))


## tests of [[<- and $<- for subclasses of environment.  At one point
## methods for these assignments were defined and caused
## inf. recursion when the arguments to the [[<- case were changed in base.
setClass("myEnv", contains = "environment")
m <- new("myEnv", a="test")
m2 <- new("myEnv"); m3 <- new("myEnv")
## test that new.env() is called for each new object
stopifnot(!identical(as.environment(m), as.environment(m2)),
          !identical(as.environment(m3), as.environment(m2)))
m[["x"]] <- 1; m$y <- 2
stopifnot(identical(c(m[["x"]], m$y), c(1,2)), is(m, "myEnv"))
rm(x, envir = m) # check rm() works, does not clobber class
stopifnot(identical(sort(objects(m)), sort(c("a", "y"))),
          is(m, "myEnv"))

## tests of binding & environment tools with subclases of environment
lockBinding("y", m)
stopifnot(bindingIsLocked("y", m))
unlockBinding("y", m)
stopifnot(!bindingIsLocked("y", m))

makeActiveBinding("z", function(value) {
    if(missing(value))
        "dummy"
    else
        "dummy assignment"
}, m)
stopifnot(identical(get("z", m),"dummy"))
## assignment will return the value but do nothing
stopifnot(identical(assign("z","other", m), "other"),
          identical(get("z", m),"dummy"))


## this has to be last--Seems no way to unlock an environment!
lockEnvironment(m)
stopifnot(environmentIsLocked(m))

rm(m)
m <- new("myEnv")
stopifnot(length(ls(m)) == 0)
## used to contain the previous content


## test of callSuper() to a hidden default method for initialize() (== initFields)
TestClass <- setRefClass ("TestClass",
     fields = list (text = "character"),
     methods = list(
       print = function ()  {cat(text)},
       initialize = function(text = "", ...) callSuper(text = paste(text, ":", sep=""),...)
  ))
tt <- TestClass("hello world")
stopifnot(identical(tt$text, "hello world:"))
## now a subclass with another field & another layer of callSuper()
TestClass2 <- setRefClass("TestClass2",
        contains = "TestClass",
        fields = list( version = "integer"),
        methods = list(
          initialize = function(..., version = 0L)
              callSuper(..., version = version+1L))
  )
tt <- TestClass2("test", version = 1L)
stopifnot(identical(tt$text, "test:"), identical(tt$version, as.integer(2)))
tt <- TestClass2(version=3L) # default text
stopifnot(identical(tt$text, ":"), identical(tt$version, as.integer(4)))


## test some capabilities but read-only for .self
.changeAllFields <- function(replacement) {
    fields <- names(.refClassDef@fieldClasses)
    for(field in fields)
        eval(substitute(.self$FIELD <- replacement$FIELD,
                        list(FIELD = field)))
}

mEditor$methods(change = .changeAllFields)
xx <- mEditor(data = xMat)
xx$edit(2, 2, 0)

yy <- mEditor(data = xMat+1)
yy$change(xx)
stopifnot(identical(yy$data, xx$data), identical(yy$edits, xx$edits))

## but don't allow assigment
if(methods:::.hasCodeTools())
        stopifnot(is(tryCatch(yy$.self$data <- xMat, error = function(e)e), "error"))

## the locked binding of refGeneratorSlot class should prevent modifying
## methods, locking fields or setting accessor methods
## Nothing special about refGeneratorSlot in this test -- the point is just
## to use a standard reference class known to be defined in a package
evr <- getRefClass("refGeneratorSlot") # in methods
stopifnot(is(tryCatch(evr$methods(foo = function()"..."), error = function(e)e), "error"),
         is(tryCatch(evr$lock("def"), error = function(e)e), "error"),
         is(tryCatch(evr$accessors("def"), error = function(e)e), "error"))

##getRefClass() method and function should work with either
## a class name or a class representation (bug report 14600)
tg <- setRefClass("tg", fields = "a")
t1 <- tg(a=1)
tgg <- t1$getRefClass()
tggg <- getRefClass("tg")
stopifnot(identical(tgg$def, tggg$def),
          identical(tg$def, tgg$def))

## this used to fail in initFieldArgs() from partial matching "self"
selfClass <- setRefClass("selfClass",
        fields=list(
            self="character", super="character", sub="character"
        )
    )

stopifnot(identical(selfClass(self="B", super="A", sub="C")$self, "B"))
## Tests for handling classes with same name & different package slots
## First:  Can we define the classes and get the separate definitions
## from the appropriate namespace or from the package slot in class(x)?
if(!require(Matrix)) q()

## from: example(chol)
sy2 <- new("dsyMatrix", Dim = as.integer(c(2,2)), x = c(14, NA,32,77))
c2 <- chol(sy2)

clM <- getClass("Cholesky")

setClass("Cholesky", contains = "numeric", representation(size = "integer"))

clG <- getClass("Cholesky", where = .GlobalEnv)

stopifnot(identical(getClass("Cholesky", where = asNamespace("Matrix")),
                    clM))

stopifnot(identical(getClass(class(c2)), clM))

stopifnot(identical(evalq(getClass("Cholesky"), asNamespace("Matrix")),
                    clM))
stopifnot(identical(getClass("Cholesky"), clG))

## Second:  tests of methods defined for the same generic
## (NOT YET!)

## Related: retaining package slots in methods signatures (reported by Martin Morgan)
setClass("A")
setGeneric("bar", function(x, y) standardGeneric("bar"))
setMethod(bar, signature(x="A", y="A"), function(x, y) {})
setMethod(bar, signature(x="A", y="ANY"), function(x, y) {})

## tests one use of .matchSigLength
stopifnot(all(nzchar(getMethod("bar", signature(x="A", y="ANY"))@target@package)))
### Moved from reg-tests-1c.R

## envRefClass prototypes are a bit special -- broke all.equal() for baseenv()
rc <- getClass("refClass")
rp <- rc@prototype
str(rp) ## failed
# rp ## show() failed .. # Throws an error - possibly due to interference from a previous test
(ner <- new("envRefClass")) # show() failed
stopifnot(all.equal(rp,rp), all.equal(ner,ner))
be <- baseenv()
system.time(stopifnot(all.equal(be,be)))## <- takes a few sec's
stopifnot(
    grepl("not identical.*character", print(all.equal(rp, ner))),
    grepl("not identical.*character", print(all.equal(ner, rp))))
system.time(stopifnot(all.equal(globalenv(), globalenv())))
## Much of the above failed in  R <= 3.2.0

proc.time()
dt <- setRefClass("dt", fields = list(data = "environment", row.names = "character"))

ev <- new.env()

d1 <- dt$new(data = ev, row.names = letters)

stopifnot(identical(d1$data, ev),
          identical(d1$row.names, letters))

# an invalid class should generate an error
d2 <- tryCatch(dt$new(data = ev, row.names = 1:12), error = function(e)e)

stopifnot(is(d2, "error"),
          grepl("row.names", d2$message, fixed = TRUE),
          grepl("character", d2$message, fixed = TRUE),
          grepl("integer", d2$message, fixed = TRUE))

# a simple subclass should be used, unchanged

setClass("tagStrings", contains = "character",
         representation(tag = "Date"))

date1 <- as.Date("2010-01-15")

t1 <- new("tagStrings", letters, tag = date1)

d3 <- dt$new(data = ev, row.names = t1)

stopifnot(identical(d3$row.names, t1))

setClass("A", representation(a="numeric"))

a1 <- new("A", a=1.5)
m1 <- as.matrix(1)

setClass("M", contains = "matrix", representation(fuzz = "numeric"))

set.seed(113)
f1 <- runif(3)

stopifnot(identical(as(new("M", 1:12, nrow = 3, fuzz = f1), "matrix"),
		    matrix(1:12, nrow=3)),
	  identical(as(new("M", 1:12, 3, fuzz = f1), "matrix"),
		    matrix(1:12, 3)),
	  identical(as(new("M", 1:12, ncol = 3, fuzz = f1), "matrix"),
		    matrix(1:12, ncol=3)))

setClass("B", contains = c("matrix", "A"))

stopifnot(## a new "B" element mixing two superclass objects
	  identical(new("B", m1, a1)@a, a1@a),
	  ## or not
	  identical(as(new("B", m1),"matrix"), m1),
	  ## or supplying a slot to override
	  identical(new("B", matrix(m1, nrow = 2), a1, a=pi)@a, pi))

## an extra level of inheritance
setClass("C", contains = "B", representation(c = "character"))
new("C", m1, c = "Testing")

## verify that validity tests work (PR#14284)
setValidity("B", function(object) {
    if(all(is.na(object@a) | (object@a > 0)))
      TRUE
    else
      "elements of slot \"a\" must be positive"
})

a2 <- new("A", a= c(NA,3, -1, 2))

## from the SoDA package on CRAN
muststop <- function(expr, silent = TRUE) {
    tryExpr <- substitute(tryCatch(expr, error=function(cond)cond))
    value <- eval.parent(tryExpr)
    if(inherits(value, "error")) {
        if(!silent)
          message("muststop reports: ", value)
        invisible(value)
    }
    else
      stop(gettextf("The expression  %s should have thrown an error, but instead returned an object of class \"%s\"",
           deparse(substitute(expr))[[1]], class(value)))
}

muststop(new("B", m1, a2))

removeClass("B")
removeClass("C")
removeClass("M")

## TODO:  make versions of above inheriting from "array" and "ts"

removeClass("A")

## removeClass() for a union where "matrix"/"array" is part:
setClassUnion("mn", c("matrix","numeric")); removeClass("mn")# gave "node stack overflow",
setClassUnion("an", c("array", "integer")); removeClass("an")#  (ditto)
setClassUnion("AM", c("array", "matrix"));  removeClass("AM")#  (ditto)
## as had "matrix" -> "array" -> "matrix" ... recursion

## and we want this to *still* work:
stopifnot(is(tryCatch(as(a3 <- array(1:24, 2:4), "matrix"), error=function(e)e),
	     "error"),
	  is(as(a2 <- array(1:12, 3:4), "matrix"),
	     "matrix"),
	  is(a2, "matrix"), is(a2, "array"), is(a3, "array"), !is(a3, "matrix"),
	  ## and yes, "for now":
	  identical(a2, matrix(1:12, 3)))

## subclassing a class that did not allow new() w/o extra args failed
## through version 3.1.1
setClass("BAR", slots = c(y="integer"))

setMethod("initialize", "BAR", function(.Object, Y) {.Object@y <- Y; .Object})

setClass("BAR3", contains = "BAR")
setClass("B", contains = "numeric")
xx <- new("B", 1)
names(xx) <- "A"
stopifnot(identical(names(xx), "A"))
setClass("A", representation(xx = "numeric"))
a <- new("A", xx = 1)
stopifnot(is(tryCatch(names(a) <- "A" , error = function(e)e), "error"))
setClass("C", representation(xx = "numeric", names= "character"))
c <- new("C", xx = 1, names = "A")
c@names <- "B"
stopifnot(is(tryCatch(names(c) <- "A" , error = function(e)e), "error"))
setClass("D", contains = "numeric", representation(names = "character"))
d <- new("D", 1)
names(d) <- "A"
stopifnot(identical(d@names, "A"))
## test the checks on @<- primitive assignment
stopifnot(is(tryCatch(a@yy <- 1 , error = function(e)e), "error"))
stopifnot(is(tryCatch(a@xx <- "A" , error = function(e)e), "error"))
setClass("A")
 # Works OK but breaks another test later - renaming B to BB avoids the issue
setClass("BB", contains = c("array", "A"))
a = array(1:12, c(2,3,4))
bb = new("BB", a)
a2 = array(8:1, rep(2,3))
stopifnot(identical(initialize(bb, a2), new("BB",a2)))

withDots <- function(x, ...) names(list(...))

setGeneric("withDots")

setClass("C", representation(x="numeric", y="character"))

setMethod("withDots", "C", function(x, ...)
          callNextMethod()
          )
stopifnot(identical(withDots(1, a=1, b=2), withDots(new("C"), a=1, b=2)))
removeClass("C"); removeClass("BB"); removeClass("A")
removeGeneric("withDots")
rm(a, bb, a2)
mEditor <- setRefClass("matrixEditor",
      fields = list( data = "matrix",
        edits = "list"),
      methods = list(
     edit = function(i, j, value) {
       ## the following string documents the edit method
       'Replaces the range [i, j] of the
        object by value.
        '
         backup <-
             list(i, j, data[i,j])
         data[i,j] <<- value
         edits <<- c(edits, list(backup))
         invisible(value)
     },
     undo = function() {
       'Undoes the last edit() operation
        and update the edits field accordingly.
        '
         prev <- edits
         if(length(prev)) prev <- prev[[length(prev)]]
         else stop("No more edits to undo")
         edit(prev[[1]], prev[[2]], prev[[3]])
         ## trim the edits list
         length(edits) <<- length(edits) - 2
         invisible(prev)
     }
     ))

xMat <- xEdited <- matrix(as.double(1:12),4,3)
xEdited[[2,2]] <- 0
xx <- mEditor$new(data = xMat)
xx$edit(2, 2, 0)
stopifnot(identical(xx$data, xEdited))
xEdited[[1,3]] <- -1
xx$edit(1,3, -1)
stopifnot(identical(xx$data, xEdited))
xx$undo()
xEdited[[1,3]] <- xMat[[1,3]]
stopifnot(identical(xx$data, xEdited))
xx$undo()
stopifnot(identical(xx$data, xMat))

## the tracing method
xx$trace(edit, quote(value <- 0))
xx$edit(2,2, -1) # traced should assign 0
stopifnot(identical(xx$data, xEdited))
xx$untrace(edit)
xx$edit(1, 3, -1) # now it should use -1
xEdited[[1,3]] <- -1
stopifnot(identical(xx$data, xEdited))
setClass("maybe")

setClass("A", representation(x = "numeric"))

setIs("A", "maybe",
      test = function(object)length(object@x) >= 1 && object@x[[1]] > 0,
      coerce = function(from)from,
      replace = function(from, value)
      stop("meaningless to replace the \"maybe\" part of an object"))

aa <- new("A", x=1)

setGeneric("ff", function(x)"default ff")
## test that the setGeneric() call created the generic & default
stopifnot(is(ff, "standardGeneric"),
          identical(body(getMethod("ff","ANY")), "default ff"))

ffMaybe <- function(x) "ff maybe method"
setMethod("ff", "maybe", ffMaybe)

aa2 <- new("A", x = -1) # condition not TRUE
stopifnot(identical(ff(aa),  "default ff"),
	  identical(ff(aa2), "default ff"))# failed in R 2.11.0

## a method to test the condition
setMethod("ff", "A",
	  function(x) {
	      if(is(x, "maybe"))
		  ffMaybe(x)
	      else
		  callNextMethod()
	  })
stopifnot(identical(ff(aa), "ff maybe method"),
          identical(ff(aa2), "default ff"))

removeClass("A")
removeClass("maybe")
removeGeneric("ff")
## reset inherited methods of group members
## (contributed by Martin Morgan, 2011-2-9)
setClass("A", representation("numeric"))
a <- new("A")

setMethod("Logic", c("A", "A"), function(e1, e2) FALSE)
res0 <- a & a                           # inherit &,A,A-method
setMethod("Logic", c("A", "A"), function(e1, e2) TRUE)
stopifnot(a & a)

removeMethod("Logic", c("A", "A"))
stopifnot(logical() == a & a)

removeClass("A")

### Find inherited group methods:
if(require(Matrix)) { ## , lib.loc = .Library
    sm <- selectMethod("-", c("dgCMatrix", "numeric"))# direct match with "Arith"
    s2 <- selectMethod("-", c("dtCMatrix", "numeric"))# ambiguity match with "Arith"
    stopifnot(sm@generic == "Arith", s2@generic == "Arith")
}
## was not ok in R 2.14.x

## some tests of callGeneric().  It's reccommended for use with group generics
setGeneric("f1", signature=c("a"),
           function(..., a) standardGeneric("f1"))
setMethod("f1", c(a="ANY"), function(..., a) list(a=a, ...))
setMethod("f1", c(a="missing"), function(..., a) callGeneric(a=1, ...))
f2 <- function(b,c,d, a) {
    if (missing(a))
        f1(b=b, c=c, d=d)
    else
        f1(a=a, b=b, c=c, d=d)
}

## use callGeneric both directly (f1) and indirectly (f2)
## Latter failed pre rev. 66408; Bug ID 15937
stopifnot(identical(c(1,2,3,4), as.vector(unlist(f1(2,3,4)))))
stopifnot(identical(c(1,2,3,4), as.vector(unlist(f2(2,3,4)))))

## test callGeneric() with no arguments.  This is rarely used
## because nearly all applications use the groups Ops, etc.
## whose members are primitives => must supply args to callGeneric

Hide <- setClass("Hide", slots = c(data = "vector"), contains = "vector")

unhide <- function(obj)
    obj@data

setGeneric("%p%", function(e1, e2) e1 + e2, group = "Ops2")
setGeneric("%gt%", function(e1, e2) e1 > e2, group = "Ops2")

setGroupGeneric("Ops2", function(e1,e2)NULL, knownMembers = c("%p%","%gt%"))

setMethod("Ops2", c("Hide", "Hide"),
          function(e1, e2) {
              e1 <- unhide(e1)
              e2 <- unhide(e2)
              callGeneric()
          })

setMethod("Ops2", c("Hide", "vector"),
          function(e1, e2) {
              e1 <- unhide(e1)
              callGeneric()
          })
setMethod("Ops2", c("vector", "Hide"),
          function(e1, e2) {
              e2 <- unhide(e2)
              callGeneric()
          })

h1 <- Hide(data = 1:10)
h2 <- Hide(data = (1:10)*.5+ 0.5)

stopifnot(all.equal(h1%p%h2, h1@data + h2@data))
stopifnot(all.equal(h1 %gt% h2, h1@data > h2@data))

removeClass("Hide")
for(g in c("f1", "%p%", "%gt%", "Ops2"))
    removeGeneric(g)


## test (non-conditional) explicit inheritance
setClass("xy", representation(x="numeric", y="numeric"))

setIs("xy", "complex",
      coerce = function(from) complex(real = from@x, imaginary = from@y),
      replace = function(from, value) {
          from@x <- Re(value)
          from@y <- Im(value)
          from
      })

set.seed(124)
x1 <- rnorm(10)
y1 <- rnorm(10)
cc <- complex(real = x1, imaginary=y1)
xyc <- new("xy", x = x1, y = y1)
stopifnot(identical(cc, as(xyc, "complex")))
as(xyc, "complex") <- cc * 1i
stopifnot(identical(xyc, new("xy", x = -y1, y = x1)))

setGeneric("size", function(x)standardGeneric("size"))
## check that generic for size() was created w/o a default method
stopifnot(is(size, "standardGeneric"),
          is.null(selectMethod("size", "ANY",optional=TRUE)))

setMethod("size", "vector", function(x)length(x))

## class "xy" should inherit the vector method through complex
stopifnot(identical(size(xyc), length(x1)))
removeClass("xy")
removeGeneric("size")


### Related to  numeric <-> double <-> integer  proposals, end of 2015, on R-devel
myN   <- setClass("myN",   contains="numeric")
myNid <- setClass("myNid", contains="numeric", representation(id="character"))
NN <-    setClass("NN", representation(x="numeric"))

(m1 <- myN  (1:3))
(m2 <- myNid(1:3, id = "i3"))
tools::assertError(NN (1:3))# in all R versions
nn <- myN(2*pi)
##                     # current R  |  (not existing)
##                     # -----------|----------
class(getDataPart(m1)) # integer    |  numeric
class(getDataPart(m2)) # integer    |  numeric
## check for now [[conceivably, these *could* change !]] :
stopifnot(identical(getDataPart(m1), 1:3),
	  identical(getDataPart(m2), 1:3),
	  identical(S3Part(m1, strict=TRUE), 1:3),
	  identical(S3Part(m2, strict=TRUE), 1:3),
	  identical(2*pi, S3Part(nn, strict = TRUE)))

if(FALSE) ## --- all these fail still:
stopifnot(
    identical(as(1L, "numeric"), as.numeric(1L))
    ,
    identical(as(1L, "numeric"), 1.0)
    ,
    is.double(as(1L, "double"))
    )
