Skip to content

Commit aaf6d16

Browse files
eddelbuetteleddelbuettel
committed
tinytest step fourteen: stat, string and subset
1 parent 454b571 commit aaf6d16

File tree

10 files changed

+439
-529
lines changed

10 files changed

+439
-529
lines changed

‎ChangeLog‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,9 @@
3232
* inst/tinytest/test_robject.R: Idem
3333
* inst/tinytest/test_s4.R: Idem
3434
* inst/tinytest/test_stack.R: Idem
35+
* inst/tinytest/test_stats.R: Idem
36+
* inst/tinytest/test_string.R: Idem
37+
* inst/tinytest/test_subset.R: Idem
3538

3639
2019-11-23 Dirk Eddelbuettel <edd@debian.org>
3740

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

File renamed without changes.

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

File renamed without changes.

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

File renamed without changes.

‎inst/tinytest/test_stats.R‎

Lines changed: 278 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,278 @@
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/stats.cpp")
25+
26+
# test.stats.dbeta <- function() {
27+
vv <- seq(0, 1, by = 0.1)
28+
a <- 0.5; b <- 2.5
29+
expect_equal(runit_dbeta(vv, a, b),
30+
list(NoLog = dbeta(vv, a, b), Log = dbeta(vv, a, b, log=TRUE)),
31+
info = " stats.qbeta")
32+
33+
# test.stats.dbinom <- function( ){
34+
v <- 1:10
35+
expect_equal(runit_dbinom(v) ,
36+
list(false = dbinom(v, 10, .5), true = dbinom(v, 10, .5, TRUE )), info = "stats.dbinom" )
37+
38+
# test.stats.dunif <- function() {
39+
vv <- seq(0, 1, by = 0.1)
40+
expect_equal(runit_dunif(vv),
41+
list(NoLog_noMin_noMax = dunif(vv),
42+
NoLog_noMax = dunif(vv, 0),
43+
NoLog = dunif(vv, 0, 1),
44+
Log = dunif(vv, 0, 1, log=TRUE),
45+
Log_noMax = dunif(vv, 0, log=TRUE)
46+
##,Log_noMin_noMax = dunif(vv, log=TRUE) ## wrong answer
47+
),
48+
info = " stats.dunif")
49+
50+
# test.stats.dgamma <- function( ) {
51+
v <- 1:4
52+
expect_equal(runit_dgamma(v),
53+
list(NoLog = dgamma(v, 1.0, 1.0),
54+
Log = dgamma(v, 1.0, 1.0, log = TRUE ),
55+
Log_noRate = dgamma(v, 1.0, log = TRUE )),
56+
info = "stats.dgamma" )
57+
58+
# test.stats.dpois <- function( ){
59+
v <- 0:5
60+
expect_equal(runit_dpois(v) ,
61+
list( false = dpois(v, .5), true = dpois(v, .5, TRUE )),
62+
info = "stats.dpois" )
63+
64+
# test.stats.dnorm <- function( ) {
65+
v <- seq(0.0, 1.0, by=0.1)
66+
expect_equal(runit_dnorm(v),
67+
list(false_noMean_noSd = dnorm(v),
68+
false_noSd = dnorm(v, 0.0),
69+
false = dnorm(v, 0.0, 1.0),
70+
true = dnorm(v, 0.0, 1.0, log=TRUE ),
71+
true_noSd = dnorm(v, 0.0, log=TRUE ),
72+
true_noMean_noSd = dnorm(v, log=TRUE )),
73+
info = "stats.dnorm" )
74+
75+
# test.stats.dt <- function( ) {
76+
v <- seq(0.0, 1.0, by=0.1)
77+
expect_equal(runit_dt(v),
78+
list(false = dt(v, 5),
79+
true = dt(v, 5, log=TRUE ) # NB: need log=TRUE here
80+
), info = "stats.dt" )
81+
82+
# test.stats.pbeta <- function( ) {
83+
a <- 0.5; b <- 2.5
84+
v <- qbeta(seq(0.0, 1.0, by=0.1), a, b)
85+
expect_equal(runit_pbeta(v, a, b),
86+
list(lowerNoLog = pbeta(v, a, b),
87+
lowerLog = pbeta(v, a, b, log=TRUE),
88+
upperNoLog = pbeta(v, a, b, lower=FALSE),
89+
upperLog = pbeta(v, a, b, lower=FALSE, log=TRUE)), info = " stats.pbeta" )
90+
## Borrowed from R's d-p-q-r-tests.R
91+
x <- c(.01, .10, .25, .40, .55, .71, .98)
92+
pbval <- c(-0.04605755624088, -0.3182809860569, -0.7503593555585,
93+
-1.241555830932, -1.851527837938, -2.76044482378, -8.149862739881)
94+
expect_equal(runit_pbeta(x, 0.8, 2)$upperLog, pbval, info = " stats.pbeta")
95+
expect_equal(runit_pbeta(1-x, 2, 0.8)$lowerLog, pbval, info = " stats.pbeta")
96+
97+
# test.stats.pbinom <- function( ) {
98+
n <- 20
99+
p <- 0.5
100+
vv <- 0:n
101+
expect_equal(runit_pbinom(vv, n, p),
102+
list(lowerNoLog = pbinom(vv, n, p),
103+
lowerLog = pbinom(vv, n, p, log=TRUE),
104+
upperNoLog = pbinom(vv, n, p, lower=FALSE),
105+
upperLog = pbinom(vv, n, p, lower=FALSE, log=TRUE)),
106+
info = " stats.pbinom")
107+
108+
# test.stats.pcauchy <- function( ) {
109+
location <- 0.5
110+
scale <- 1.5
111+
vv <- 1:5
112+
expect_equal(runit_pcauchy(vv, location, scale),
113+
list(lowerNoLog = pcauchy(vv, location, scale),
114+
lowerLog = pcauchy(vv, location, scale, log=TRUE),
115+
upperNoLog = pcauchy(vv, location, scale, lower=FALSE),
116+
upperLog = pcauchy(vv, location, scale, lower=FALSE, log=TRUE)),
117+
info = " stats.pcauchy")
118+
119+
# test.stats.punif <- function( ) {
120+
v <- qunif(seq(0.0, 1.0, by=0.1))
121+
expect_equal(runit_punif(v),
122+
list(lowerNoLog = punif(v),
123+
lowerLog = punif(v, log=TRUE ),
124+
upperNoLog = punif(v, lower=FALSE),
125+
upperLog = punif(v, lower=FALSE, log=TRUE)),
126+
info = "stats.punif" )
127+
# TODO: also borrow from R's d-p-q-r-tests.R
128+
129+
# test.stats.pf <- function( ) {
130+
v <- (1:9)/10
131+
expect_equal(runit_pf(v),
132+
list(lowerNoLog = pf(v, 6, 8, lower=TRUE, log=FALSE),
133+
lowerLog = pf(v, 6, 8, log=TRUE ),
134+
upperNoLog = pf(v, 6, 8, lower=FALSE),
135+
upperLog = pf(v, 6, 8, lower=FALSE, log=TRUE)),
136+
info = "stats.pf" )
137+
138+
# test.stats.pnf <- function( ) {
139+
v <- (1:9)/10
140+
expect_equal(runit_pnf(v),
141+
list(lowerNoLog = pf(v, 6, 8, ncp=2.5, lower=TRUE, log=FALSE),
142+
lowerLog = pf(v, 6, 8, ncp=2.5, log=TRUE ),
143+
upperNoLog = pf(v, 6, 8, ncp=2.5, lower=FALSE),
144+
upperLog = pf(v, 6, 8, ncp=2.5, lower=FALSE, log=TRUE)),
145+
info = "stats.pnf" )
146+
147+
# test.stats.pchisq <- function( ) {
148+
v <- (1:9)/10
149+
expect_equal(runit_pchisq(v),
150+
list(lowerNoLog = pchisq(v, 6, lower=TRUE, log=FALSE),
151+
lowerLog = pchisq(v, 6, log=TRUE ),
152+
upperNoLog = pchisq(v, 6, lower=FALSE),
153+
upperLog = pchisq(v, 6, lower=FALSE, log=TRUE)),
154+
info = "stats.pchisq" )
155+
156+
# test.stats.pnchisq <- function( ) {
157+
v <- (1:9)/10
158+
expect_equal(runit_pnchisq(v),
159+
list(lowerNoLog = pchisq(v, 6, ncp=2.5, lower=TRUE, log=FALSE),
160+
lowerLog = pchisq(v, 6, ncp=2.5, log=TRUE ),
161+
upperNoLog = pchisq(v, 6, ncp=2.5, lower=FALSE),
162+
upperLog = pchisq(v, 6, ncp=2.5, lower=FALSE, log=TRUE)),
163+
info = "stats.pnchisq" )
164+
165+
# test.stats.pgamma <- function( ) {
166+
v <- (1:9)/10
167+
expect_equal(runit_pgamma(v),
168+
list(lowerNoLog = pgamma(v, shape = 2.0),
169+
lowerLog = pgamma(v, shape = 2.0, log=TRUE ),
170+
upperNoLog = pgamma(v, shape = 2.0, lower=FALSE),
171+
upperLog = pgamma(v, shape = 2.0, lower=FALSE, log=TRUE)),
172+
info = "stats.pgamma" )
173+
174+
# test.stats.pnorm <- function( ) {
175+
v <- qnorm(seq(0.0, 1.0, by=0.1))
176+
expect_equal(runit_pnorm(v),
177+
list(lowerNoLog = pnorm(v),
178+
lowerLog = pnorm(v, log=TRUE ),
179+
upperNoLog = pnorm(v, lower=FALSE),
180+
upperLog = pnorm(v, lower=FALSE, log=TRUE)),
181+
info = "stats.pnorm" )
182+
## Borrowed from R's d-p-q-r-tests.R
183+
z <- c(-Inf,Inf,NA,NaN, rt(1000, df=2))
184+
z.ok <- z > -37.5 | !is.finite(z)
185+
pz <- runit_pnorm(z)
186+
expect_equal(pz$lowerNoLog, 1 - pz$upperNoLog, info = "stats.pnorm")
187+
expect_equal(pz$lowerNoLog, runit_pnorm(-z)$upperNoLog, info = "stats.pnorm")
188+
expect_equal(log(pz$lowerNoLog[z.ok]), pz$lowerLog[z.ok], info = "stats.pnorm")
189+
## FIXME: Add tests that use non-default mu and sigma
190+
191+
# test.stats.ppois <- function( ) {
192+
vv <- 0:20
193+
expect_equal(runit_ppois(vv),
194+
list(lowerNoLog = ppois(vv, 0.5),
195+
lowerLog = ppois(vv, 0.5, log=TRUE),
196+
upperNoLog = ppois(vv, 0.5, lower=FALSE),
197+
upperLog = ppois(vv, 0.5, lower=FALSE, log=TRUE)),
198+
info = " stats.ppois")
199+
200+
# test.stats.pt <- function( ) {
201+
v <- seq(0.0, 1.0, by=0.1)
202+
expect_equal(runit_pt(v),
203+
list(lowerNoLog = pt(v, 5),
204+
lowerLog = pt(v, 5, log=TRUE),
205+
upperNoLog = pt(v, 5, lower=FALSE),
206+
upperLog = pt(v, 5, lower=FALSE, log=TRUE) ),
207+
info = "stats.pt" )
208+
209+
# test.stats.pnt <- function( ) {
210+
v <- seq(0.0, 1.0, by=0.1)
211+
expect_equal(runit_pnt(v),
212+
list(lowerNoLog = pt(v, 5, ncp=7),
213+
lowerLog = pt(v, 5, ncp=7, log=TRUE),
214+
upperNoLog = pt(v, 5, ncp=7, lower=FALSE),
215+
upperLog = pt(v, 5, ncp=7, lower=FALSE, log=TRUE) ),
216+
info = "stats.pnt" )
217+
218+
# test.stats.qbinom <- function( ) {
219+
n <- 20
220+
p <- 0.5
221+
vv <- seq(0, 1, by = 0.1)
222+
expect_equal(runit_qbinom_prob(vv, n, p),
223+
list(lower = qbinom(vv, n, p),
224+
upper = qbinom(vv, n, p, lower=FALSE)),
225+
info = " stats.qbinom")
226+
227+
# test.stats.qunif <- function( ) {
228+
expect_equal(runit_qunif_prob(c(0, 1, 1.1, -.1)),
229+
list(lower = c(0, 1, NaN, NaN),
230+
upper = c(1, 0, NaN, NaN)),
231+
info = "stats.qunif" )
232+
# TODO: also borrow from R's d-p-q-r-tests.R
233+
234+
# test.stats.qnorm <- function( ) {
235+
expect_equal(runit_qnorm_prob(c(0, 1, 1.1, -.1)),
236+
list(lower = c(-Inf, Inf, NaN, NaN),
237+
upper = c(Inf, -Inf, NaN, NaN)),
238+
info = "stats.qnorm" )
239+
## Borrowed from R's d-p-q-r-tests.R and Wichura (1988)
240+
expect_equal(runit_qnorm_prob(c( 0.25, .001, 1e-20))$lower,
241+
c(-0.6744897501960817, -3.090232306167814, -9.262340089798408),
242+
info = "stats.qnorm",
243+
tol = 1e-15)
244+
245+
expect_equal(runit_qnorm_log(c(-Inf, 0, 0.1)),
246+
list(lower = c(-Inf, Inf, NaN),
247+
upper = c(Inf, -Inf, NaN)),
248+
info = "stats.qnorm" )
249+
expect_equal(runit_qnorm_log(-1e5)$lower, -447.1974945)
250+
251+
# test.stats.qpois.prob <- function( ) {
252+
vv <- seq(0, 1, by = 0.1)
253+
expect_equal(runit_qpois_prob(vv),
254+
list(lower = qpois(vv, 0.5),
255+
upper = qpois(vv, 0.5, lower=FALSE)),
256+
info = " stats.qpois.prob")
257+
258+
# test.stats.qt <- function( ) {
259+
v <- seq(0.05, 0.95, by=0.05)
260+
( x1 <- runit_qt(v, 5, FALSE, FALSE) )
261+
( x2 <- qt(v, df=5, lower=FALSE, log=FALSE) )
262+
expect_equal(x1, x2, info="stats.qt.f.f")
263+
264+
( x1 <- runit_qt(v, 5, TRUE, FALSE) )
265+
( x2 <- qt(v, df=5, lower=TRUE, log=FALSE) )
266+
expect_equal(x1, x2, info="stats.qt.t.f")
267+
268+
( x1 <- runit_qt(-v, 5, FALSE, TRUE) )
269+
( x2 <- qt(-v, df=5, lower=FALSE, log=TRUE) )
270+
expect_equal(x1, x2, info="stats.qt.f.t")
271+
272+
( x1 <- runit_qt(-v, 5, TRUE, TRUE) )
273+
( x2 <- qt(-v, df=5, lower=TRUE, log=TRUE) )
274+
expect_equal(x1, x2, info="stats.qt.t.t")
275+
276+
277+
## TODO: test.stats.qgamma
278+
## TODO: test.stats.(dq)chisq

‎inst/tinytest/test_string.R‎

Lines changed: 84 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,84 @@
1+
2+
## Copyright (C) 2012 - 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/String.cpp")
25+
26+
# test.replace_all <- function(){
27+
expect_equal( String_replace_all("abcdbacdab", "ab", "AB"), "ABcdbacdAB")
28+
29+
# test.replace_first <- function(){
30+
expect_equal( String_replace_first("abcdbacdab", "ab", "AB"), "ABcdbacdab")
31+
32+
# test.replace_last <- function(){
33+
expect_equal( String_replace_last("abcdbacdab", "ab", "AB"), "abcdbacdAB")
34+
35+
# test.String.sapply <- function(){
36+
res <- test_sapply_string( "foobar", c("o", "a" ), c("*", "!" ) )
37+
expect_equal( res, "f**b!r" )
38+
39+
# test.compare.Strings <- function(){
40+
res <- test_compare_Strings( "aaa", "aab" )
41+
target <- list("a < b" = TRUE,
42+
"a > b" = FALSE,
43+
"a == b" = FALSE,
44+
"a == a" = TRUE)
45+
expect_equal( res, target )
46+
47+
# test.compare.String.string_proxy <- function(){
48+
v <- c("aab")
49+
res <- test_compare_String_string_proxy( "aaa", v )
50+
target <- list("a == b" = FALSE,
51+
"a != b" = TRUE,
52+
"b == a" = FALSE,
53+
"b != a" = TRUE)
54+
expect_equal( res, target )
55+
56+
# test.compare.String.const_string_proxy <- function(){
57+
v <- c("aab")
58+
res <- test_compare_String_const_string_proxy( "aaa", v )
59+
target <- list("a == b" = FALSE,
60+
"a != b" = TRUE,
61+
"b == a" = FALSE,
62+
"b != a" = TRUE)
63+
expect_equal( res, target )
64+
65+
# test.String.ctor <- function() {
66+
res <- test_ctor("abc")
67+
expect_identical(res, "abc")
68+
69+
# test.push.front <- function() {
70+
res <- test_push_front("def")
71+
expect_identical(res, "abcdef")
72+
73+
# test.String.encoding <- function() {
74+
a <- b <- "å"
75+
Encoding(a) <- "unknown"
76+
Encoding(b) <- "UTF-8"
77+
expect_equal(test_String_encoding(a), 0)
78+
expect_equal(test_String_encoding(b), 1)
79+
expect_equal(Encoding(test_String_set_encoding(a)), "UTF-8")
80+
expect_equal(Encoding(test_String_ctor_encoding(a)), "UTF-8")
81+
expect_equal(Encoding(test_String_ctor_encoding2()), "UTF-8")
82+
83+
# test.String.embeddedNul <- function() {
84+
expect_error(test_String_embeddedNul())

0 commit comments

Comments
 (0)