Skip to content

Commit 4d884d0

Browse files
committed
tinytest step twelve: convert na, pkgskel, reference, rmath, robject
1 parent de44723 commit 4d884d0

20 files changed

+1086
-1189
lines changed

ChangeLog

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
2019-11-24 Dirk Eddelbuettel <edd@debian.org>
22

3-
* tests/tinytest.R: Converted from RUnit to tinytest
3+
* tests/tinytest.R: Converted from RUnit to tinytest
44
* inst/tinytest/test_algorithm.R: Idem
55
* inst/tinytest/test_as.R: Idem
66
* inst/tinytest/test_binary_package.R: Idem (but inactive for now)
@@ -24,7 +24,13 @@
2424
* inst/tinytest/test_modref.R: Idem
2525
* inst/tinytest/test_module.R: Idem
2626
* inst/tinytest/test_module_client_package.R: Idem
27-
27+
* inst/tinytest/test_na.R: Idem
28+
* inst/tinytest/test_quickanddirty.R: Idem
29+
* inst/tinytest/test_rcpp_package_skeleton.R: Idem
30+
* inst/tinytest/test_reference.R: Idem
31+
* inst/tinytest/test_rmath.R: Idem
32+
* inst/tinytest/test_robject.R: Idem
33+
2834
2019-11-23 Dirk Eddelbuettel <edd@debian.org>
2935

3036
* docker/ci/Dockerfile: Add tinytest to ci Docker image

inst/tinytest/test_date.R

100755100644
File mode changed.

inst/tinytest/test_na.R

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
2+
## Copyright (C) 2014 Kevin Ushey
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/na.cpp")
25+
26+
#test.na <- function() {
27+
expect_identical( R_IsNA_(NA_real_), Rcpp_IsNA(NA_real_) )
28+
expect_identical( R_IsNA_(NA_real_+1), Rcpp_IsNA(NA_real_+1) )
29+
expect_identical( R_IsNA_(NA_real_+NaN), Rcpp_IsNA(NA_real_+NaN) )
30+
expect_identical( R_IsNA_(NaN+NA_real_), Rcpp_IsNA(NaN+NA_real_) )
31+
expect_identical( R_IsNaN_(NA_real_), Rcpp_IsNaN(NA_real_) )
32+
expect_identical( R_IsNaN_(NaN), Rcpp_IsNaN(NaN) )
33+
expect_identical( R_IsNaN_(NaN+1), Rcpp_IsNaN(NaN+1) )
Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,21 @@
11

2+
## Copyright (C) 2019 Dirk Eddelbuettel
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+
219
library(Rcpp)
320

421
Rcpp::sourceCpp("cpp/rcppversion.cpp")

inst/tinytest/test_quickanddirty.R

Lines changed: 52 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,52 @@
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/rmath.cpp")
25+
26+
#test.rmath.norm <- function() {
27+
x <- 0.25
28+
a <- 1.25
29+
b <- 2.50
30+
expect_equal(runit_dnorm(x, a, b),
31+
c(dnorm(x, a, b, log=FALSE), dnorm(x, a, b, log=TRUE)),
32+
info = " rmath.dnorm")
33+
34+
expect_equal(runit_pnorm(x, a, b),
35+
c(pnorm(x, a, b, lower=TRUE, log=FALSE), pnorm(log(x), a, b, lower=TRUE, log=TRUE),
36+
pnorm(x, a, b, lower=FALSE, log=FALSE), pnorm(log(x), a, b, lower=FALSE, log=TRUE)),
37+
info = " rmath.pnorm")
38+
39+
expect_equal(runit_qnorm(x, a, b),
40+
c(qnorm(x, a, b, lower=TRUE, log=FALSE), qnorm(log(x), a, b, lower=TRUE, log=TRUE),
41+
qnorm(x, a, b, lower=FALSE, log=FALSE), qnorm(log(x), a, b, lower=FALSE, log=TRUE)),
42+
info = " rmath.qnorm")
43+
44+
set.seed(333)
45+
rcpp_result <- runit_rnorm(a, b)
46+
set.seed(333)
47+
rcpp_result_sugar <- runit_rnorm_sugar(a, b)
48+
set.seed(333)
49+
r_result <- rnorm(5, a, b)
50+
51+
expect_equal(rcpp_result, r_result, info = " rmath.rnorm")
52+
expect_equal(rcpp_result_sugar, r_result, info = " rmath.rnorm.sugar")
Lines changed: 150 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,150 @@
1+
2+
## Copyright (C) 2013 - 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+
## override -- skipping test for now (need to rebuild binary)
22+
.runThisTest <- FALSE
23+
24+
if (!.runThisTest) exit_file("Skipping, set 'RunAllRcppTests=yes' to run.")
25+
26+
library(Rcpp)
27+
28+
# test.Rcpp.package.skeleton <- function(){
29+
30+
tempdir <- tempdir()
31+
path <- tempdir
32+
pkg_path <- file.path(path, "foo")
33+
R_path <- file.path(pkg_path, "R")
34+
src_path <- file.path(pkg_path, "src")
35+
env <- new.env()
36+
37+
env$funA <- function(alpha, beta) "gamma"
38+
env$funB <- function(first, ..., last) "foo"
39+
40+
Rcpp.package.skeleton("foo", path=path, list=c("funA", "funB"),
41+
author="Boo-Boo Bear",
42+
maintainer="Yogi Bear",
43+
license="An Opensource License",
44+
email="yogibear@yogimail.com",
45+
environment=env)
46+
47+
checkTrue( "foo" %in% list.files(path), "pkg path generated as named" )
48+
49+
## check the DESCRIPTION
50+
DESCRIPTION <- as.list( read.dcf( file.path(pkg_path, "DESCRIPTION") )[1,] )
51+
checkTrue( DESCRIPTION["Author"] == "Boo-Boo Bear",
52+
"wrote the Author field in DESCRIPTION" )
53+
checkTrue( DESCRIPTION["Maintainer"] == "Yogi Bear <yogibear@yogimail.com>",
54+
"wrote the Maintainer field in DESCRIPTION")
55+
checkTrue( DESCRIPTION["License"] == "An Opensource License",
56+
"wrote the License field in DESCRIPTION" )
57+
checkTrue( DESCRIPTION["LinkingTo"] == "Rcpp",
58+
"we make sure that we 'link' to Rcpp (use its headers)" )
59+
60+
## make sure we have useDynLib in the namespace
61+
NAMESPACE <- readLines( file.path(pkg_path, "NAMESPACE") )
62+
63+
## note: we use regular expressions anticipating a possible future
64+
## usage of e.g. '.registration=TRUE' in Rcpp.package.skeleton
65+
checkTrue( any(grepl( "useDynLib(foo", NAMESPACE, fixed=TRUE )),
66+
"NAMESPACE has useDynLib(foo)" )
67+
68+
R_files <- list.files(R_path, full.names=TRUE)
69+
checkTrue( all( c("funA.R", "funB.R") %in% list.files(R_path)),
70+
"created R files from functions" )
71+
for (file in grep("RcppExports.R", R_files, invert=TRUE, value=TRUE)) {
72+
code <- readLines(file)
73+
fn <- eval(parse(text=paste(code, collapse="\n")))
74+
fn_name <- gsub(".*/(.*)\\.R$", "\\1", file)
75+
checkIdentical(fn, get(fn_name),
76+
sprintf("we parsed the function '%s' correctly", fn_name)
77+
)
78+
}
79+
80+
## make sure we can build the package as generated
81+
## note: the generated .Rd placeholders are insufficient to be able
82+
## to successfully install the pkg; e.g. I see
83+
84+
## Error in Rd_info(db[[i]]) :
85+
## missing/empty \title field in '<path>/funA.Rd'
86+
invisible(sapply( list.files( file.path(pkg_path, "man"), full.names=TRUE), unlink ))
87+
88+
owd <- getwd()
89+
setwd(path)
90+
R <- shQuote( file.path( R.home( component = "bin" ), "R" ))
91+
system( paste(R, "CMD build", pkg_path) )
92+
checkTrue( file.exists("foo_1.0.tar.gz"), "can successfully R CMD build the pkg")
93+
dir.create("templib")
94+
install.packages("foo_1.0.tar.gz", file.path(path, "templib"), repos=NULL, type="source")
95+
require("foo", file.path(path, "templib"), character.only=TRUE)
96+
97+
98+
# test.Rcpp.package.skeleton.Attributes <- function() {
99+
tempdir <- tempdir()
100+
path <- tempdir
101+
if (dir.exists(file.path(path, "foo"))) unlink(file.path(path, "foo"), recursive=TRUE)
102+
pkg_path <- file.path(path, "foo")
103+
R_path <- file.path(pkg_path, "R")
104+
src_path <- file.path(pkg_path, "src")
105+
106+
Rcpp.package.skeleton("foo", path=path, attributes=TRUE, example_code=TRUE,
107+
environment=environment())
108+
checkTrue(file.exists( file.path(src_path, "RcppExports.cpp")),
109+
"RcppExports.cpp was created")
110+
checkTrue(file.exists( file.path(src_path, "rcpp_hello_world.cpp")),
111+
"rcpp_hello_world.cpp was created" )
112+
checkTrue(file.exists( file.path(R_path, "RcppExports.R")),
113+
"RcppExports.R was created")
114+
#on.exit( unlink(pkg_path, recursive=TRUE), add=TRUE )
115+
unlink(pkg_path, recursive=TRUE)
116+
117+
# test.Rcpp.package.skeleton.NoAttributes <- function() {
118+
tempdir <- tempdir()
119+
path <- tempdir
120+
pkg_path <- file.path(path, "foo")
121+
R_path <- file.path(pkg_path, "R")
122+
src_path <- file.path(pkg_path, "src")
123+
124+
Rcpp.package.skeleton("foo", path=path, attributes=FALSE, example_code=TRUE,
125+
environment=environment())
126+
checkTrue(file.exists( file.path(src_path, "rcpp_hello_world.cpp")),
127+
"rcpp_hello_world.cpp was created")
128+
checkTrue(file.exists( file.path(src_path, "rcpp_hello_world.h")),
129+
"rcpp_hello_world.h was created")
130+
checkTrue(file.exists( file.path(R_path, "rcpp_hello_world.R")),
131+
"rcpp_hello_world.R was created" )
132+
on.exit( unlink(pkg_path, recursive=TRUE) )
133+
134+
# test.Rcpp.package.skeleton.Module <- function() {
135+
tempdir <- tempdir()
136+
path <- tempdir
137+
pkg_path <- file.path(path, "foo")
138+
R_path <- file.path(pkg_path, "R")
139+
src_path <- file.path(pkg_path, "src")
140+
141+
Rcpp.package.skeleton("foo", path=path, module=TRUE, environment=environment())
142+
checkTrue(file.exists( file.path(src_path, "rcpp_module.cpp")),
143+
"rcpp_module.cpp was created")
144+
145+
on.exit(unlink(pkg_path, recursive=TRUE))
146+
on.exit( setwd(owd), add=TRUE )
147+
on.exit( unlink( file.path(path, "foo_1.0.tar.gz") ), add=TRUE)
148+
on.exit( unlink( file.path(path, "templib"), recursive=TRUE), add=TRUE )
149+
on.exit( unlink(pkg_path, recursive=TRUE), add=TRUE )
150+
on.exit(unlink(pkg_path, recursive=TRUE), add=TRUE)

0 commit comments

Comments
 (0)