Skip to content

Commit 454b571

Browse files
eddelbuetteleddelbuettel
committed
tinytest step thirteen+: s4 and stack
1 parent 21ec527 commit 454b571

File tree

7 files changed

+256
-280
lines changed

7 files changed

+256
-280
lines changed

‎ChangeLog‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,8 @@
3030
* inst/tinytest/test_reference.R: Idem
3131
* inst/tinytest/test_rmath.R: Idem
3232
* inst/tinytest/test_robject.R: Idem
33+
* inst/tinytest/test_s4.R: Idem
34+
* inst/tinytest/test_stack.R: Idem
3335

3436
2019-11-23 Dirk Eddelbuettel <edd@debian.org>
3537

inst/unitTests/cpp/S4.cpp renamed to inst/tinytest/cpp/S4.cpp

File renamed without changes.

inst/unitTests/cpp/stack.cpp renamed to inst/tinytest/cpp/stack.cpp

File renamed without changes.

‎inst/tinytest/test_s4.R‎

Lines changed: 94 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,94 @@
1+
2+
## Copyright (C) 2010 - 2019 Dirk Eddelbuettel and Romain Francois
3+
##
4+
## This file is part of Rcpp.
5+
##
6+
## Rcpp is free software: you can redistribute it and/or modify it
7+
## under the terms of the GNU General Public License as published by
8+
## the Free Software Foundation, either version 2 of the License, or
9+
## (at your option) any later version.
10+
##
11+
## Rcpp is distributed in the hope that it will be useful, but
12+
## WITHOUT ANY WARRANTY; without even the implied warranty of
13+
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14+
## GNU General Public License for more details.
15+
##
16+
## You should have received a copy of the GNU General Public License
17+
## along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
18+
19+
.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
20+
21+
if (!.runThisTest) exit_file("Skipping, set 'RunAllRcppTests=yes' to run.")
22+
23+
library(Rcpp)
24+
sourceCpp("cpp/S4.cpp")
25+
26+
# test.RObject.S4methods <- function(){
27+
setClass("track", representation(x="numeric", y="numeric"))
28+
tr <- new( "track", x = 2, y = 2 )
29+
expect_equal(S4_methods(tr), list( TRUE, TRUE, FALSE, 2.0, 2.0 ), info = "slot management" )
30+
31+
S4_getslots( tr )
32+
expect_equal( tr@x, 10.0 , info = "slot('x') = 10" )
33+
expect_equal( tr@y, 20.0 , info = "slot('y') = 20" )
34+
35+
expect_error( S4_setslots( tr ), info = "slot does not exist" )
36+
expect_error( S4_setslots_2( tr ), info = "slot does not exist" )
37+
38+
39+
40+
# test.S4 <- function(){
41+
setClass("track", representation(x="numeric", y="numeric"))
42+
tr <- new( "track", x = 2, y = 3 )
43+
expect_equal( S4_get_slot_x( tr ), 2, info = "S4( SEXP )" )
44+
expect_error( S4_get_slot_x( list( x = 2, y = 3 ) ), info = "not S4" )
45+
expect_error( S4_get_slot_x( structure( list( x = 2, y = 3 ), class = "track" ) ), info = "S3 is not S4" )
46+
47+
tr <- S4_ctor( "track" )
48+
expect_true( inherits( tr, "track" ) )
49+
expect_equal( tr@x, numeric(0) )
50+
expect_equal( tr@y, numeric(0) )
51+
expect_error( S4_ctor( "someclassthatdoesnotexist" ) )
52+
53+
54+
# test.S4.is <- function(){
55+
setClass("track", representation(x="numeric", y="numeric"))
56+
setClass("trackCurve", representation(smooth = "numeric"), contains = "track")
57+
58+
tr1 <- new( "track", x = 2, y = 3 )
59+
tr2 <- new( "trackCurve", x = 2, y = 3, smooth = 5 )
60+
61+
expect_true( S4_is_track( tr1 ), info = 'track is track' )
62+
expect_true( S4_is_track( tr2 ), info = 'trackCurve is track' )
63+
64+
expect_true( !S4_is_trackCurve( tr1 ), info = 'track is not trackCurve' )
65+
expect_true( S4_is_trackCurve( tr2 ), info = 'trackCurve is trackCurve' )
66+
67+
68+
69+
# test.Vector.SlotProxy.ambiguity <- function(){
70+
setClass("track", representation(x="numeric", y="numeric"))
71+
setClass("trackCurve", representation(smooth = "numeric"), contains = "track")
72+
73+
tr1 <- new( "track", x = 2, y = 3 )
74+
expect_equal( S4_get_slot_x(tr1), 2, info="Vector( SlotProxy ) ambiguity" )
75+
76+
77+
78+
# test.Vector.AttributeProxy.ambiguity <- function(){
79+
x <- 1:10
80+
attr( x, "foo" ) <- "bar"
81+
82+
expect_equal( S4_get_attr_x(x), "bar", info="Vector( AttributeProxy ) ambiguity" )
83+
84+
85+
86+
# test.S4.dotdataslot <- function(){
87+
setClass( "Foo", contains = "character", representation( x = "numeric" ) )
88+
foo <- S4_dotdata( new( "Foo", "bla", x = 10 ) )
89+
expect_equal( as.character( foo) , "foooo" )
90+
91+
# test.S4.proxycoerce <- function() {
92+
setClass("Foo", list(data="integer"))
93+
foo <- new("Foo", data=1:3)
94+
expect_equal( S4_proxycoerce(foo), c(1, 2, 3) )

‎inst/tinytest/test_stack.R‎

Lines changed: 160 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,160 @@
1+
2+
## Copyright (C) 2010 - 2019 Dirk Eddelbuettel and Romain Francois
3+
##
4+
## This file is part of Rcpp.
5+
##
6+
## Rcpp is free software: you can redistribute it and/or modify it
7+
## under the terms of the GNU General Public License as published by
8+
## the Free Software Foundation, either version 2 of the License, or
9+
## (at your option) any later version.
10+
##
11+
## Rcpp is distributed in the hope that it will be useful, but
12+
## WITHOUT ANY WARRANTY; without even the implied warranty of
13+
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14+
## GNU General Public License for more details.
15+
##
16+
## You should have received a copy of the GNU General Public License
17+
## along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
18+
19+
.runThisTest <- Sys.getenv("RunAllRcppTests") == "yes"
20+
21+
if (!.runThisTest) exit_file("Skipping, set 'RunAllRcppTests=yes' to run.")
22+
23+
library(Rcpp)
24+
sourceCpp("cpp/stack.cpp")
25+
26+
27+
## On old versions of R, Rcpp_fast_eval() falls back to Rcpp_eval() and
28+
## leaks on longjumps
29+
hasUnwind <- getRversion() >= "3.5.0"
30+
checkUnwound <- if (hasUnwind) expect_true else function(x) expect_identical(x, NULL)
31+
checkErrorMessage <- function(x, msg) {
32+
if (!hasUnwind) {
33+
msg <- paste0("Evaluation error: ", msg, ".")
34+
}
35+
expect_identical(x$message, msg)
36+
}
37+
evalUnwind <- function(expr, indicator) {
38+
testFastEval(expr, parent.frame(), indicator)
39+
}
40+
41+
## Wrap the unwind indicator in an environment because mutating
42+
## vectors passed by argument can corrupt the R session in
43+
## byte-compiled code.
44+
newIndicator <- function() {
45+
env <- new.env()
46+
env$unwound <- NULL
47+
env
48+
}
49+
50+
## Stack is always unwound on errors and interrupts
51+
# test.stackUnwindsOnErrors <- function() {
52+
indicator <- newIndicator()
53+
out <- tryCatch(evalUnwind(quote(stop("err")), indicator), error = identity)
54+
expect_true(indicator$unwound)
55+
checkErrorMessage(out, "err")
56+
57+
58+
# test.stackUnwindsOnInterrupts <- function() {
59+
if (.Platform$OS.type != "windows") {
60+
indicator <- newIndicator()
61+
expr <- quote({
62+
repeat testSendInterrupt()
63+
"returned"
64+
})
65+
out <- tryCatch(evalUnwind(expr, indicator), interrupt = function(c) "onintr")
66+
expect_true(indicator$unwound)
67+
expect_identical(out, "onintr")
68+
}
69+
70+
# test.stackUnwindsOnCaughtConditions <- function() {
71+
indicator <- newIndicator()
72+
expr <- quote(signalCondition(simpleCondition("cnd")))
73+
cnd <- tryCatch(evalUnwind(expr, indicator), condition = identity)
74+
expect_true(inherits(cnd, "simpleCondition"))
75+
checkUnwound(indicator$unwound)
76+
77+
# test.stackUnwindsOnRestartJumps <- function() {
78+
indicator <- newIndicator()
79+
expr <- quote(invokeRestart("rst"))
80+
out <- withRestarts(evalUnwind(expr, indicator), rst = function(...) "restarted")
81+
expect_identical(out, "restarted")
82+
checkUnwound(indicator$unwound)
83+
84+
# test.stackUnwindsOnReturns <- function() {
85+
indicator <- newIndicator()
86+
expr <- quote(signalCondition(simpleCondition(NULL)))
87+
out <- callCC(function(k) {
88+
withCallingHandlers(evalUnwind(expr, indicator), simpleCondition = function(e) k("jumped"))
89+
})
90+
expect_identical(out, "jumped")
91+
checkUnwound(indicator$unwound)
92+
93+
# test.stackUnwindsOnReturnedConditions <- function() {
94+
indicator <- newIndicator()
95+
cnd <- simpleError("foo")
96+
out <- tryCatch(evalUnwind(quote(cnd), indicator), error = function(c) "abort")
97+
expect_true(indicator$unwound)
98+
99+
## The old mechanism cannot differentiate between a returned error and a
100+
## thrown error
101+
if (hasUnwind) {
102+
expect_identical(out, cnd)
103+
} else {
104+
expect_identical(out, "abort")
105+
}
106+
107+
## Longjump from the inner protected eval
108+
# test.stackUnwindsOnNestedEvalsInner <- function() {
109+
indicator1 <- newIndicator()
110+
indicator2 <- newIndicator()
111+
innerUnwindExpr <- quote(evalUnwind(quote(invokeRestart("here", "jump")), indicator2))
112+
out <- withRestarts(
113+
here = identity,
114+
evalUnwind(innerUnwindExpr, indicator1)
115+
)
116+
117+
expect_identical(out, "jump")
118+
checkUnwound(indicator1$unwound)
119+
checkUnwound(indicator2$unwound)
120+
121+
## Longjump from the outer protected eval
122+
# test.stackUnwindsOnNestedEvalsOuter <- function() {
123+
indicator1 <- newIndicator()
124+
indicator2 <- newIndicator()
125+
innerUnwindExpr <- quote({
126+
evalUnwind(NULL, indicator2)
127+
invokeRestart("here", "jump")
128+
})
129+
out <- withRestarts(here = identity, evalUnwind(innerUnwindExpr, indicator1))
130+
131+
expect_identical(out, "jump")
132+
checkUnwound(indicator1$unwound)
133+
expect_true(indicator2$unwound) # Always unwound
134+
135+
# test.unwindProtect <- function() {
136+
if (hasUnwind) {
137+
indicator <- newIndicator()
138+
expect_error(testUnwindProtect(indicator, fail = TRUE))
139+
expect_true(indicator$unwound)
140+
141+
indicator <- newIndicator()
142+
expect_error(testUnwindProtectLambda(indicator, fail = TRUE))
143+
expect_true(indicator$unwound)
144+
145+
indicator <- newIndicator()
146+
expect_error(testUnwindProtectFunctionObject(indicator, fail = TRUE))
147+
expect_true(indicator$unwound)
148+
149+
indicator <- newIndicator()
150+
expect_equal(testUnwindProtect(indicator, fail = FALSE), 42)
151+
expect_true(indicator$unwound)
152+
153+
indicator <- newIndicator()
154+
expect_equal(testUnwindProtectLambda(indicator, fail = FALSE), 42)
155+
expect_true(indicator$unwound)
156+
157+
indicator <- newIndicator()
158+
expect_equal(testUnwindProtectFunctionObject(indicator, fail = FALSE), 420)
159+
expect_true(indicator$unwound)
160+
}

‎inst/unitTests/runit.S4.R‎

Lines changed: 0 additions & 103 deletions
This file was deleted.

0 commit comments

Comments
 (0)